Private Sub CommandButton1_Click()
Dim chemin$, d As Object, i%, x$, nomfich$, dL%, wb As Workbook, F As Worksheet, j%
chemin = ThisWorkbook.Path & "\Mes fichiers\" 'nom du dossier à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
'---création des classeurs---
MkDir chemin 'création du sous-dossier
Set d = CreateObject("Scripting.Dictionary")
With Range("A1", UsedRange).EntireColumn
For i = 4 To .Columns.Count
x = .Cells(2, i)
nomfich = Split(x)(0) & ".xls"
dL = Len(x) + Len(.Cells(3, i)) - 30 'nom d'onglet limité à 31 caractères
If Not d.exists(nomfich) Then
d(nomfich) = ""
Workbooks(nomfich).Close
Workbooks.Add(xlWBATWorksheet).SaveAs chemin & nomfich, 56 'fichier .xls
End If
Set wb = Workbooks(nomfich)
Set F = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count)) 'nouvelle feuille
F.Name = Left(x, Len(x) - dL) & " " & .Cells(3, i)
j = .Cells(2, i).MergeArea.Columns.Count 'pour DM2:DN2 qui sont fusionnées
Union(.Columns(1).Resize(, 3), .Columns(i).Resize(, j)).Copy F.Range("A1")
F.Columns(4).Resize(, j).AutoFit 'ajustement largeur
i = i + j - 1
Next i
End With
'---fermeture des classeurs---
For Each wb In Workbooks
If d.exists(wb.Name) Then
wb.Activate
wb.Sheets(1).Delete
wb.Sheets(1).Activate
wb.Close True 'avec enregistrement
End If
Next wb
End Sub
