Sub distribue()
Dim tbl1, tbl2, i As Long, ii As Long, j As Long, jj As Long
Feuil1.Range("R4:T35").ClearContents
tbl1 = Feuil1.Range("A4:T35")
tbl2 = Feuil2.Range("A2:H10")
For j = 5 To UBound(tbl2, 2)
For i = 2 To UBound(tbl2, 1)
If tbl2(i, j) = "" Then
For ii = 2 To UBound(tbl1, 1)
If tbl1(ii, 3) = tbl2(1, j) And tbl1(ii, 1) = tbl2(i, 4) Then
tbl1(ii, 18) = tbl2(1, j) 'pour contrôle
tbl1(ii, 19) = tbl2(i, 1): tbl1(ii, 20) = tbl2(i, 2) 'perso,groupe
End If
Next ii
End If
Next i
Next j
Feuil1.Range("A4").Resize(UBound(tbl1, 1), UBound(tbl1, 2)) = tbl1
End Sub
bonjour Julie
bienvenue
à mettre dans un module
tu peux supprimer la ligne commentée pour contrôle
Code:Sub distribue() Dim tbl1, tbl2, i As Long, ii As Long, j As Long, jj As Long Feuil1.Range("R4:T35").ClearContents tbl1 = Feuil1.Range("A4:T35") tbl2 = Feuil2.Range("A2:H10") For j = 5 To UBound(tbl2, 2) For i = 2 To UBound(tbl2, 1) If tbl2(i, j) = "" Then For ii = 2 To UBound(tbl1, 1) If tbl1(ii, 3) = tbl2(1, j) And tbl1(ii, 1) = tbl2(i, 4) Then tbl1(ii, 18) = tbl2(1, j) 'pour contrôle tbl1(ii, 19) = tbl2(i, 1): tbl1(ii, 20) = tbl2(i, 2) 'perso,groupe End If Next ii End If Next i Next j Feuil1.Range("A4").Resize(UBound(tbl1, 1), UBound(tbl1, 2)) = tbl1 End Sub
Sub distribue()
Dim tbl1, tbl2, i As Long, ii As Long, j As Long, jj As Long
Application.ScreenUpdating = False
Feuil1.Range("R5:T" & Feuil1.Range("A65536").End(xlUp).Row).ClearContents
tbl1 = Feuil1.Range("A4:T" & Feuil1.Range("A65536").End(xlUp).Row)
tbl2 = Feuil2.Range("A2:Q" & Feuil1.Range("A65536").End(xlUp).Row)
For j = 5 To UBound(tbl2, 2)
For i = 2 To UBound(tbl2, 1)
If tbl2(i, j) = "" Then
For ii = 2 To UBound(tbl1, 1)
If tbl1(ii, 3) = tbl2(1, j) And tbl1(ii, 1) = tbl2(i, 4) Then
tbl1(ii, 18) = tbl2(1, j) 'pour contrôle,à effacer
tbl1(ii, 19) = tbl2(i, 1): tbl1(ii, 20) = tbl2(i, 2) 'perso,groupe
End If
Next ii
End If
Next i
Next j
' Feuil1.Range("A4").Resize(UBound(tbl1, 1), UBound(tbl1, 2)) = tbl1'remet tout le tableau
Feuil1.Range("S4").Resize(UBound(tbl1, 1)) = Application.Index(tbl1, , 19) 'remet la colonne 19,colonne S
Feuil1.Range("T4").Resize(UBound(tbl1, 1)) = Application.Index(tbl1, , 20) 'remet la colonne 20,colonne T
Application.ScreenUpdating = True
End Sub
Hello,bonjour Julie
code complété
Code:Sub distribue() Dim tbl1, tbl2, i As Long, ii As Long, j As Long, jj As Long Application.ScreenUpdating = False Feuil1.Range("R5:T" & Feuil1.Range("A65536").End(xlUp).Row).ClearContents tbl1 = Feuil1.Range("A4:T" & Feuil1.Range("A65536").End(xlUp).Row) tbl2 = Feuil2.Range("A2:Q" & Feuil1.Range("A65536").End(xlUp).Row) For j = 5 To UBound(tbl2, 2) For i = 2 To UBound(tbl2, 1) If tbl2(i, j) = "" Then For ii = 2 To UBound(tbl1, 1) If tbl1(ii, 3) = tbl2(1, j) And tbl1(ii, 1) = tbl2(i, 4) Then tbl1(ii, 18) = tbl2(1, j) 'pour contrôle,à effacer tbl1(ii, 19) = tbl2(i, 1): tbl1(ii, 20) = tbl2(i, 2) 'perso,groupe End If Next ii End If Next i Next j ' Feuil1.Range("A4").Resize(UBound(tbl1, 1), UBound(tbl1, 2)) = tbl1'remet tout le tableau Feuil1.Range("S4").Resize(UBound(tbl1, 1)) = Application.Index(tbl1, , 19) 'remet la colonne 19,colonne S Feuil1.Range("T4").Resize(UBound(tbl1, 1)) = Application.Index(tbl1, , 20) 'remet la colonne 20,colonne T Application.ScreenUpdating = True End Sub
Sub distribue1()
Dim tbl1, tbl2, i As Long, ii As Long, j As Long, jj As Long
Application.ScreenUpdating = False
Feuil1.Range("R5:T" & Feuil1.Range("A65536").End(xlUp).Row).ClearContents
tbl1 = Feuil1.Range("A4:T" & Feuil1.Range("A65536").End(xlUp).Row)
tbl2 = Feuil2.Range("A2:Q" & Feuil1.Range("A65536").End(xlUp).Row)
For ii = 2 To UBound(tbl1, 1)
For i = 2 To UBound(tbl2, 1)
If tbl1(ii, 1) = tbl2(i, 4) Then
For j = 5 To UBound(tbl2, 2)
If tbl1(ii, 3) = tbl2(1, j) Then
If tbl2(i, j) = "" Then
tbl1(ii, 18) = tbl2(1, j) 'pour contrôle,à effacer
tbl1(ii, 19) = tbl2(i, 1): tbl1(ii, 20) = tbl2(i, 2) 'perso,groupe
End If
End If
Next j
End If
Next i
Next ii
' Feuil1.Range("A4").Resize(UBound(tbl1, 1), UBound(tbl1, 2)) = tbl1'remet tout le tableau
Feuil1.Range("R4").Resize(UBound(tbl1, 1)) = Application.Index(tbl1, , 18) 'remet la colonne 18,colonne R
Feuil1.Range("S4").Resize(UBound(tbl1, 1)) = Application.Index(tbl1, , 19) 'remet la colonne 19,colonne S
Feuil1.Range("T4").Resize(UBound(tbl1, 1)) = Application.Index(tbl1, , 20) 'remet la colonne 20,colonne T
Application.ScreenUpdating = True
End Sub
Sub distribue2()
Dim tbl1, tbl2, i As Long, ii As Long, j As Long, jj As Long
Dim tbl2a(), NbCategorie As Long
ii = 1: NbCategorie = Application.CountIf(Feuil2.Range("E3:Q25"), "=" & "")
Application.ScreenUpdating = False
Feuil1.Range("R5:T" & Feuil1.Range("A65536").End(xlUp).Row).ClearContents
tbl1 = Feuil1.Range("A4:T" & Feuil1.Range("A65536").End(xlUp).Row)
tbl2 = Feuil2.Range("A2:Q" & Feuil1.Range("A65536").End(xlUp).Row)
For i = 2 To UBound(tbl2, 1)
' If i > UBound(tbl2, 1) Then Exit For
For j = 5 To UBound(tbl2, 2)
If tbl2(i, j) = "" Then
ReDim Preserve tbl2a(1 To 4, 1 To ii)
tbl2a(1, ii) = tbl2(i, 4): tbl2a(2, ii) = tbl2(1, j): tbl2a(3, ii) = tbl2(i, 1)
tbl2a(4, ii) = tbl2(i, 2): If ii < NbCategorie Then ii = ii + 1
End If
Next j
If ii = NbCategorie Then Exit For
Next i
tbl2a = Application.Transpose(tbl2a)
' Feuil3.Range("A1").Resize(UBound(tbl2a, 1), UBound(tbl2a, 2)) = tbl2a 'remet tout le tableau
For i = 2 To UBound(tbl1, 1)
For ii = 2 To UBound(tbl2a, 1)
If tbl1(i, 1) = tbl2a(ii, 1) And tbl1(i, 3) = tbl2a(ii, 2) Then
tbl1(i, 18) = tbl2a(ii, 2) 'pour contrôle,à effacer
tbl1(i, 19) = tbl2a(ii, 3): tbl1(i, 20) = tbl2a(ii, 4) 'perso,groupe
End If
Next ii
Next i
Feuil1.Range("S4").Resize(UBound(tbl1, 1)) = Application.Index(tbl1, , 19) 'remet la colonne 19,colonne S
Feuil1.Range("T4").Resize(UBound(tbl1, 1)) = Application.Index(tbl1, , 20) 'remet la colonne 20,colonne T
Application.ScreenUpdating = True
End Sub
Bonjour, Roger et BebereBonjour julie211, Bebere.
Un essai...
Bonne soirée.
ℝOGER2327
#8435
Samedi 28 Sable 144 (Saint Cervelas, penseur - fête Suprême Quarte)
8 Nivôse An CCXXV, 6,9432h - fumier
2016-W52-3T16:39:49Z