Sub GénérerClasseurs()
Dim d As Object, wbk As Workbook, k, itm, kitm, kk, et, f%, n%, i%, ch$, rw$
Set d = CreateObject("Scripting.Dictionary")
With ThisWorkbook
For f = 1 To .Worksheets.Count
With .Worksheets(f)
n = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 2 To n
kitm = .Cells(i, 1)
k = "wb_" & kitm: itm = "ws" & f
If d.exists(k) Then
If InStr(d(k), itm) = 0 Then d(k) = d(k) & ";" & itm
Else
d(k) = ";" & itm
End If
k = itm & "_" & kitm: kitm = kitm & "_" & itm: itm = "rw" & i
If d.exists(k) Then
If InStr(d(k), itm) = 0 Then d(k) = d(k) & ";" & itm
Else
d(k) = ";" & itm
End If
kitm = kitm & itm: itm = .Cells(i, 1).Resize(, 3).Value
d(kitm) = itm
Next i
End With
Next f
et = .Worksheets(1).Range("A1:W1").Value
ch = .Path & "\"
End With
Application.ScreenUpdating = False
For Each k In d.keys
If k Like "wb_*" Then
kitm = Split(k, "_")(1)
Set wbk = Workbooks.Add(xlWBATWorksheet)
wbk.SaveAs ch & kitm & ".csv"
itm = Split(d(k), ";")
With wbk
If UBound(itm) > 1 Then
For f = 2 To UBound(itm)
.Worksheets.Add after:=.Worksheets(f - 1)
Next f
End If
For f = 1 To UBound(itm)
kk = Split(d(itm(f) & "_" & kitm), ";"): n = 1
With .Worksheets(f)
.Cells(n, 1).Resize(, 3).Value = et
For i = 1 To UBound(kk)
n = n + 1
rw = kitm & "_" & itm(f) & kk(i)
.Cells(n, 1).Resize(, 3).Value = d(rw)
Next i
End With
Next f
.Close True
End With
End If
Set wbk = Nothing
Next k
End Sub