1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78
| Option Explicit
Sub Affiche_Resultat()
Dim DerLig_f1 As Long, DerLig_f2 As Long, i As Long, c As Long, LigTrouvee As Long, NbLig As Long
Dim f1 As Worksheet, f2 As Worksheet
Dim Valeur As Double
Application.ScreenUpdating = False
Set f1 = Sheets("Entrée")
Set f2 = Sheets("Résultat")
DerLig_f1 = f1.Range("D" & Rows.Count).End(xlUp).Row
f2.Range("B1:Q" & DerLig_f1).Value = f1.Range("B1:Q" & DerLig_f1).Value
'Premièrement, on concatène les critères (Pièce, Nom, Taille) puis on numérote les lignes en fonction de ces critères
f2.Range("S2:S" & DerLig_f1).FormulaR1C1 = "=RC[-16]&"" ""&RC[-15]&"" ""&RC[-14]"
f2.Range("T2").FormulaR1C1 = "1"
f2.Range("T3:T" & DerLig_f1).FormulaR1C1 = "=IF(COUNTIF(R2C19:R[-1]C[-1],RC[-1])>0,INDIRECT(""T""&MATCH(RC[-1],R2C19:R[-1]C[-1],0)+1),MAX(R2C20:R[-1]C20)+1)"
f2.Range("U2:U" & DerLig_f1).FormulaR1C1 = "=IF(RC[-17]<>R[-1]C[-17],1,"""")"
f2.Range("S2:U" & DerLig_f1).Value = f2.Range("S2:U" & DerLig_f1).Value
For i = DerLig_f1 To 2 Step -1
If f2.Cells(i, "U") = "" Then
'on recherche si le même numéro existe dans la colonne U
Valeur = f2.Cells(i, "T")
On Error Resume Next
LigTrouvee = Application.WorksheetFunction.Match(Valeur, f2.Range("T1:T" & i - 1), 0)
If LigTrouvee = 0 Then
'On compte le nombre de Lignes qui la sépare de la première ligne du même nom
NbLig = 0
For c = i To 2 Step -1
If f2.Cells(c, "U") = 1 Then Exit For
If f2.Cells(c, "U") <> 1 Then
NbLig = NbLig + 1
End If
Next c
f2.Cells(i, 21 + NbLig) = f2.Cells(i, "L")
Else
'On compte le nombre de Lignes qui les sépare
NbLig = i - LigTrouvee
If f2.Cells(LigTrouvee, "U") = 1 Then
f2.Cells(LigTrouvee, 21 + NbLig) = f2.Cells(i, "L")
Else
f2.Cells(LigTrouvee, 21 + NbLig + 1) = f2.Cells(i, "L")
End If
NbLig = 0
End If
f2.Cells(i, "S").ClearContents
LigTrouvee = 0
Else
f2.Cells(i, "U") = f2.Cells(i, "L")
End If
Next i
f2.Select
'Suppression des lignes vides
For i = DerLig_f1 To 2 Step -1
If Application.WorksheetFunction.CountA(Range(f2.Cells(i, "U"), f2.Cells(i, "Z"))) = 0 Then
f2.Rows(i).Delete
End If
Next i
f2.Range("M2:Q" & Range("D" & Rows.Count).End(xlUp).Row).FormulaR1C1 = "=IF(RC[9]="""","""",RC[9])"
f2.Range("M2:Q" & Range("D" & Rows.Count).End(xlUp).Row).Value = f2.Range("M2:Q" & Range("D" & Rows.Count).End(xlUp).Row).Value
'Suppression des doublons
DerLig_f2 = f2.Range("D" & Rows.Count).End(xlUp).Row
For i = DerLig_f2 To 2 Step -1
If Application.WorksheetFunction.CountIf(Range(f2.Cells(i, "M"), f2.Cells(i, "Q")), f2.Cells(i, "L")) > 0 Then
f2.Cells(i, "L").ClearContents
End If
Next i
f2.Columns("S:Z").ClearContents
Set f1 = Nothing
Set f2 = Nothing
End Sub |
Partager