Dim I As Long, J As Long, macol As New Collection, quoi Application.ScreenUpdating = False For I = 1 To UBound(tablo1) For J = 1 To UBound(tablo2) If Sheets("Fiche_machine").Range("A1") = tablo2(J, 2) Then If tablo1(I, 2) = tablo2(J, 1) Then If tablo1(I, 1) = tablo2(J, 5) Then If tablo2(J, 8) <= 14 Then If InStr(tablo1(I, 3), vbCrLf) = 0 Then tablo1(I, 3) = tablo2(J, 3) Else tablo1(I, 3) = tablo1(I, 3) & Chr(10) & tablo2(J, 3) On Error Resume Next macol.Add I, Str(I) End If End If End If End If End If Next J Next I Sheets("Fiche_machine").Range("A22:C" & derlign1) = tablo1 For I = macol.Count To 1 Step -1 quoi = Split(Range("C" & macol.Item(I)), Chr(10)) For J = UBound(quoi) To 1 Step -1 Rows(macol.Item(I) + 1).Insert , xlShiftDown Range("C" & macol.Item(I) + 1).Value = quoi(J) Next J Range("C" & macol.Item(I)).Value = quoi(0) Next Application.ScreenUpdating = true
Sub fichemachine2() Dim I As Long, J As Long, macol As New Collection, derlign1 As Byte, derlign2 As Integer Dim tablo1() As Variant, tablo2() As Variant, quoi derlign1 = Sheets("Fiche_machine").Range("B" & Rows.Count).End(xlUp).Row derlign2 = Sheets("Maxituo").Range("A" & Rows.Count).End(xlUp).Row tablo1 = Sheets("Fiche_machine").Range("A22:C" & derlign1) tablo2 = Sheets("Maxituo").Range("A3:K" & derlign2) Application.ScreenUpdating = False For I = 1 To UBound(tablo1) For J = 1 To UBound(tablo2) If Sheets("Fiche_machine").Range("A1") = tablo2(J, 2) Then If tablo1(I, 2) = tablo2(J, 1) Then If tablo1(I, 1) = tablo2(J, 5) Then If tablo2(J, 8) <= 14 Then If InStr(tablo1(I, 3), vbCrLf) = 0 Then tablo1(I, 3) = tablo2(J, 3) Else tablo1(I, 3) = tablo1(I, 3) & Chr(10) & tablo2(J, 3) On Error Resume Next macol.add I + 21, Str(I + 21) End If End If End If End If End If Next J Next I Sheets("Fiche_machine").Range("A22:C" & derlign1) = tablo1 For I = macol.Count To 1 Step -1 quoi = Split(Range("C" & macol.Item(I)), Chr(10)) For J = UBound(quoi) To 1 Step -1 Rows(macol.Item(I) + 1).Insert , xlShiftDown Range("C" & macol.Item(I) + 1).Value = quoi(J) Next J Range("C" & macol.Item(I)).Value = quoi(0) Next Application.ScreenUpdating = True End Sub
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre questionSub fichemachineuc() Dim I As Long, J As Long, macol As New Collection, derlign1 As Byte, derlign2 As Integer, quoi derlign1 = Sheets("Fiche_machine").Range("B" & Rows.Count).End(xlUp).Row + 3 derlign2 = Sheets("Maxituo").Range("A" & Rows.Count).End(xlUp).Row tablo1 = Sheets("Fiche_machine").Range("A22:C" & derlign1) tablo2 = Sheets("Maxituo").Range("A3:K" & derlign2) Application.ScreenUpdating = False For I = 1 To UBound(tablo1) For J = 1 To UBound(tablo2) If Sheets("Fiche_machine").Range("A1") = tablo2(J, 2) Then If tablo1(I, 2) = tablo2(J, 1) Then If tablo1(I, 1) = tablo2(J, 5) Then If tablo2(J, 8) <= 14 Then If InStr(tablo1(I, 3), vbCrLf) = 0 Then tablo1(I, 3) = tablo2(J, 3) Else tablo1(I, 3) = tablo1(I, 3) & Chr(10) & tablo2(J, 3) On Error Resume Next macol.add I + 21, Str(I + 21) End If End If End If End If End If Next J Next I Sheets("Fiche_machine").Range("A22:C" & derlign1) = tablo1 For I = macol.Count To 1 Step -1 quoi = Split(Range("C" & macol.Item(I)), Chr(10)) For J = UBound(quoi) To 1 Step -1 Rows(macol.Item(I) + 1).Insert , xlShiftDown Range("C" & macol.Item(I) + 1).Value = quoi(J) Next J Range("C" & macol.Item(I)).Value = quoi(0) Next I Application.ScreenUpdating = True End Sub
une avec les tenants, l'autre avec les aboutissants, le tout : accompagné des commentaires nécessaires quant à la relation entre le "départ" et "l'arrivée" !