Option Explicit
Sub test()
Dim dico As Object, i As Long, n As Long, txt As String, e
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
With Sheets("Feuil1").Range("a6").CurrentRegion
For i = 2 To .Rows.Count
txt = .Rows(i).Cells(2).Value & ";" & .Rows(i).Cells(9).Value
If i = 2 Then
Set dico(txt) = .Rows(1)
End If
If Not dico.exists(txt) Then
Set dico(txt) = .Rows(i)
Else
Set dico(txt) = Union(dico(txt), .Rows(i))
End If
Next
End With
Application.ScreenUpdating = False
With Sheets("Feuil2")
.Cells.Clear
For Each e In dico
n = n + 1
dico(e).Copy .Cells(n, 1)
Application.DisplayAlerts = False
With .Cells(n, 1).CurrentRegion
If n = 1 Then n = 2
If UCase(.Cells(n, 9)) = "FAUX" Then
With .Offset(.Rows.Count).Resize(1)
.Cells(1) = "Total facture"
.Cells(11) = "=sum(r" & n & "c:r[-1]c)"
End With
With .Range(.Cells(n, 1), .Cells(.Rows.Count, 1))
.Merge
With .Resize(, 2)
.VerticalAlignment = xlCenter
.Interior.ColorIndex = 43
End With
End With
With .Range(.Cells(n, 2), .Cells(.Rows.Count, 2))
.Merge
End With
n = .Rows.Count + 1
Else
With .Offset(.Rows.Count).Resize(1)
.Cells(1) = "Timbre"
.Cells(11) = 500
.Cells(1).Offset(1) = "Total facture"
.Cells(11).Offset(1) = "=sum(r" & n & "c:r[-1]c)"
End With
With .Range(.Cells(n, 1), .Cells(.Rows.Count, 1))
.Merge
With .Resize(, 2)
.VerticalAlignment = xlCenter
.Interior.ColorIndex = 37
End With
End With
With .Range(.Cells(n, 2), .Cells(.Rows.Count, 2))
.Merge
End With
n = .Rows.Count + 2
End If
End With
Application.DisplayAlerts = True
Next
.Cells(1).CurrentRegion.Rows(1).Interior.ColorIndex = 38
End With
Application.ScreenUpdating = True
Set dico = Nothing
End Sub