Sub Recopie()
Dim a, i As Long, j As Long, w(), x, y, txt As String
Application.ScreenUpdating = False
'a = Sheets("Export").Range("B3").CurrentRegion.Value
'a = Sheets("Export").Range("B3", Sheets("Export").Cells.SpecialCells(11)).Value
With Sheets("Export").Range("B3", Sheets("Export").Cells.SpecialCells(11))
a = Application.Index(.Value, Evaluate("row(1:" & _
.Rows.Count & ")"), Array(1, 2, 3, 4, 6, 7, 9))
End With
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
txt = a(i, 1)
If Not .exists(txt) Then .Item(txt) = Empty
If IsEmpty(.Item(txt)) Then
ReDim w(1 To UBound(a, 2), 1 To 1)
Else
w = .Item(txt)
ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 1)
End If
For j = 1 To UBound(a, 2)
w(j, UBound(w, 2)) = a(i, j)
Next
.Item(txt) = w
Next
x = .keys: y = .items
End With
For i = 0 To UBound(x)
On Error Resume Next
Application.DisplayAlerts = False
Sheets(x(i)).Delete
On Error GoTo 0
Sheets.Add(after:=Sheets(Sheets.Count)).Name = x(i)
With Sheets(x(i)).Cells(1).Resize(, UBound(a, 2))
.Value = a
.Offset(1).Resize(UBound(y(i), 2)).Value = _
Application.Transpose(y(i))
End With
With Sheets(x(i)).Cells(1).CurrentRegion
With .Offset(.Rows.Count).Resize(1)
.Formula = "=sum(r2c:r[-1]c)"
.Cells(1) = "Totaux"
'.Cells(5) = "": .Cells(8) = ""
.BorderAround Weight:=xlThin
.Interior.ColorIndex = 19
End With
With .Rows(1)
.Interior.ColorIndex = 44
.BorderAround Weight:=xlThin
End With
With .Resize(.Rows.Count + 1)
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.Borders(xlInsideVertical).Weight = xlThin
.BorderAround Weight:=xlThin
.EntireColumn.AutoFit
End With
End With
Next
Application.ScreenUpdating = True
End Sub