Sub GénérerClasseurs()
Dim aa, rh, ln, EPCI(), plgET As Range, chD$, k%, n&, i&, d As Object
With Worksheets("Etat 2")
i = .Range("A" & .Rows.Count).End(xlUp).Row
If i <= 1 Then Exit Sub
k = .Cells.SpecialCells(xlCellTypeLastCell).Column
aa = .Range("A2:A" & i).Resize(, k).Value
Set plgET = .Range("A1:A1").Resize(, k)
End With
chD = ThisWorkbook.Path & "\"
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(aa)
d(aa(i, 1)) = d(aa(i, 1)) & ";" & i
Next i
Application.ScreenUpdating = False
For Each rh In d.keys
ln = Split(d(rh), ";"): n = UBound(ln)
ReDim EPCI(1 To n)
For i = 1 To n
EPCI(i) = WorksheetFunction.Index(aa, CInt(ln(i)), 0)
Next i
With Workbooks.Add(xlWBATWorksheet)
With .Worksheets(1)
plgET.Copy .Range("A1")
With .Range("A2").Resize(n, k)
.Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(EPCI))
.Borders.Weight = xlThin
End With
End With
.SaveAs chD & rh & ".xlsx"
.Close
End With
Next rh
End Sub