Re,
Recopie cette procédure dans un module standard de ton PERSONAL.XLSB.
Puis dans la barre d'accès rapide, tu ajoutes un bouton que tu rattaches à cette procédure.
Attention à la partie surlignée (je ne suis pas expert!). On supprime le répertoire CP et ses fichiers si celui-ci existe!?.
A te relire.
Option Explicit
'Option Private Module
Public Sub CopyToWorkbooks()
Dim wb As Workbook
Dim ws As Worksheet, ws2 As Worksheet, WSNew As Worksheet
Dim lo As ListObject
Dim Cell As Range
Dim Lrow As Long, FileFormatNum As Long, FieldNum As Long
Dim sFolderName As String, sPath As String, FileExtStr As String
Dim fso As Object
Dim CalcMode As XlCalculation
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
Set lo = ws.ListObjects(1)
FieldNum = 7
If lo.ShowAutoFilter Then
lo.AutoFilter.ShowAllData
End If
FileExtStr = ".xlsx": FileFormatNum = 51
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
.ScreenUpdating = False
'.EnableEvents = False
End With
On Error Resume Next
wb.Worksheets("Temp").Delete
On Error GoTo 0
Set ws2 = wb.Worksheets.Add(after:=Sheets(Sheets.Count))
ws2.Name = "Temp"
sPath = wb.Path & Application.PathSeparator
sFolderName = sPath & "CP"
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.folderexists(sFolderName) Then
fso.deletefolder (sFolderName)
End If
MkDir sFolderName & Application.PathSeparator
With ws2
lo.ListColumns(FieldNum).Range.AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("A1"), Unique:=True
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each Cell In .Range("A2:A" & Lrow)
lo.Range.AutoFilter Field:=FieldNum, Criteria1:="=" & Cell.Value
Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
lo.Range.SpecialCells(xlCellTypeVisible).Copy
With WSNew.Range("A1")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
.Select
End With
With WSNew
.ListObjects.Add(xlSrcRange, .Cells(1, 1).CurrentRegion, , xlYes).Name = "tbl_" & Cell.Value
.ListObjects(1).TableStyle = "TableStyleLight8"
End With
WSNew.Parent.SaveAs sFolderName & Application.PathSeparator & Cell.Value & FileExtStr, FileFormatNum
WSNew.Parent.Close False
lo.Range.AutoFilter Field:=FieldNum
Next Cell
.Delete
End With
With Application
.DisplayAlerts = True
.ScreenUpdating = True
'.EnableEvents = True
.Calculation = CalcMode
End With
Set fso = Nothing
Set lo = Nothing
Set WSNew = Nothing: Set ws2 = Nothing: Set ws = Nothing
Set wb = Nothing
End Sub