1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30
| Sub Dispaching()
Dim LastCol As Integer
Dim c As Range
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Feuil1")
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For Each c In .Range("A1").Resize(1, LastCol)
Transfer c
Next c
End With
End Sub
'Procédure qui copie la colonne correspondant à Rng dans un nouveau classeur sauvegardé sous le nom contenu dans Rng
'Attention si Rng contient des caractères non permis dans la nommination des fichier tel /?
Private Sub Transfer(ByVal Rng As Range)
Dim Wbk As Workbook
Dim Chemin As String
Chemin = ThisWorkbook.Path & "\"
Set Wbk = Workbooks.Add(1)
Rng.EntireColumn.Copy Wbk.Worksheets(1).Range("A1")
Application.DisplayAlerts = False
Wbk.SaveAs Chemin & Rng.Value
Application.DisplayAlerts = True
Wbk.Close
Set Wbk = Nothing
End Sub |