Problème Macro extraction

Bonjour à tous,

Voici mon problème :

J'ai un fichier excel avec des données clients en colonne. J'ai ainsi créer une macro afin de pouvoir extraire chaque colonne pour créer un fichier excel par client, voici la macro que j'utilise :

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("B1")
Application.DisplayAlerts = False
Wbk.SaveAs Chemin & Rng.Value
Application.DisplayAlerts = True
Wbk.Close
Set Wbk = Nothing
End Sub

J'aimerais maintenant copier la colonne A sur tous mes fichiers en colonne A également. Comment pourrais-je réaliser ceci?

Merci beaucoup!

Salut,

On peut voir ton fichier ? Ou au moins un fichier modèle ?

Bonnes salutations.

Rosees a écrit :

Bonjour à tous,

Voici mon problème :

J'ai un fichier excel avec des données clients en colonne. J'ai ainsi créer une macro afin de pouvoir extraire chaque colonne pour créer un fichier excel par client, voici la macro que j'utilise :

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)
Columns("A:A").copy wbk.worksheets(1).range("A1")
Rng.EntireColumn.Copy Wbk.Worksheets(1).Range("B1")
Application.DisplayAlerts = False
Wbk.SaveAs Chemin & Rng.Value
Application.DisplayAlerts = True
Wbk.Close
Set Wbk = Nothing
End Sub

J'aimerais maintenant copier la colonne A sur tous mes fichiers en colonne A également. Comment pourrais-je réaliser ceci?

Merci beaucoup!

bonsoir,

je pense qu'il suffit de rajouter l'instruction surlignée dans ta procédure transfer

Bonjour à tous,

Je vous remercie de vos réponses, problème résolu!