Boucle de macro en double

Bonjour

je rencontre un problème avec la macro suivante, et je ne voie pas l'erreur. elle commence très bien à copier les lignes d'un tableau pour le coller dans un nouveau en collant également la 1er ligne du tableau initial. ensuite pour chaque nouveau fichier Excel créé, la macro doit le nommer avec le nom contenu en A2.

elle nomme correctement les fichiers dans un 1er temps mais ensuite elle double les fichiers en les appelant tous par le contenu de A2 en rajoutant un chiffre pour éviter d'écraser. (cela double le nombre de fichiers...)

un regard averti m'aiderai fortement

Merci

sub extraire_lignes_final()

'Déclaration des variables
Dim wbSource As Workbook
Dim wbDest As Workbook
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim i As Long
Dim j As Long
Dim LastRow As Long
Dim NewFileName As String
Dim DestFolder As String
Dim SourceRange As Range

'Ouverture du fichier source
Set wbSource = ThisWorkbook
Set wsSource = wbSource.Sheets("liste_a_trier") 'Nom de la feuille contenant le tableau

'Détermination de la dernière ligne du tableau
LastRow = wsSource.Cells(Rows.Count, 1).End(xlUp).Row

'Boucle pour créer un nouveau fichier pour chaque ligne du tableau
For i = 2 To LastRow 'on commence à la ligne 2 pour exclure la première ligne du tableau

'Nom du nouveau fichier à partir de la cellule A2
NewFileName = wsSource.Cells(2, 1).value & "_" & i - 1 & ".xlsx" 'i-1 pour éviter le nom "nomdufichier_1.xlsx"

'Création d'un nouveau fichier
Set wbDest = Workbooks.Add
Set wsDest = wbDest.Sheets("Feuil1")

'Copie de la première ligne du tableau
For j = 1 To wsSource.Cells(1, Columns.Count).End(xlToLeft).Column
    wsDest.Cells(1, j).value = wsSource.Cells(1, j).value
Next j

'Copie de la ligne correspondante du tableau
For j = 1 To wsSource.Cells(1, Columns.Count).End(xlToLeft).Column
    wsDest.Cells(2, j).value = wsSource.Cells(i, j).value
Next j

'Définit le nom du fichier
Set SourceRange = wsSource.Range("A1")
DestFolder = "D:\DestFolder\"
wbDest.SaveAs filename:=DestFolder & SourceRange.Cells(i, 1).value & ".xlsx", FileFormat:=xlOpenXMLWorkbook 'ok pour valeur de la 1ere colonne

'Enregistrement et fermeture du nouveau fichier
wbDest.SaveAs DestFolder & NewFileName
wbDest.Close

'Nettoyage de la mémoire
Set wbDest = Nothing
Set wsDest = Nothing
Next i

'Nettoyage de la mémoire
Set wbSource = Nothing
Set wsSource = Nothing

End Sub

Bonjour,

Peut-être ici l'erreur:

NewFileName = wsSource.Cells(2, 1).value & "_" & i - 1 & ".xlsx" 'i-1 pour éviter le nom "nomdufichier_1.xlsx"

Cells(2, 1)= cellule A2 , à la place du 2, il faudrait mettre i, Cells(i, 1)

Cdlt

bonjour et merci Arturo83

j'ai corrigé et c'est mieux , mais maintenant tous les fichiers sont en doubles (voir copie écran). il doit bien exister un moyen simple de ne pas avoir les doublons d'autant plus que la macro détermine la dernière ligne du tableau .

je suis preneur

Merci par avance

Oui mais, avec ces 3 lignes:

        NewFileName = wsSource.Cells(i, 1).Value & "_" & i - 1 & ".xlsx" 'i-1 pour éviter le nom "nomdufichier_1.xlsx"

        wbDest.SaveAs Filename:=DestFolder & SourceRange.Cells(i, 1).Value & ".xlsx", FileFormat:=xlOpenXMLWorkbook 'ok pour valeur de la 1ere colonne

        wbDest.SaveAs DestFolder & NewFileName 'Enregistrement et fermeture du nouveau fichier

La première créée le fichier ""fichier_1.xlsx""

L a seconde enregistre le fichier en "fichier.xlsx"

et la troisième enregistre le premier fichier, donc il est normal que vous ayez ce résultat.

Après, difficile d'en dire plus rien qu'en analysant un bout de code sans fichier.

j'ai supprimer la ligne (wbDest.SaveAs DestFolder & NewFileName) et ça fonctionne super

MERCI

'Enregistrement et fermeture du nouveau fichier
'wbDest.SaveAs DestFolder & NewFileName
wbDest.Close

j'ai une petite question supplémentaire

lorsque j'ai des lignes qui commence par le même contenu (colonne A), j'aurai bien voulu mettre ces lignes dans le même fichier (par exemple coller les 4 lignes "Captain america" dans un nouveau fichier (il y a 40 colonnes !)

Merci pour l'aide

Bonjour,

Voici le code comme demandé, j'ai supposé que le fichier était trié auparavant par la colonne A, si ce n'est pas le cas, il faudra ajouter le tri dans le code.

Cette macro est dissociée de la précédente, vous l'associerez à un bouton pour pouvoir l'exécuter quand bon vous semble.

Sub Nouveau_Classeur_Pour_Doublons()
    'Déclaration des variables
    Dim wbSource As Workbook
    Dim wbDest As Workbook
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim i As Long
    Dim LastRow As Long
    Dim NewFileName As String
    Dim DestFolder As String
    Dim SourceRange As Range

    Application.ScreenUpdating = False
    'Ouverture du fichier source
    Set wbSource = ThisWorkbook
    Set wsSource = wbSource.Sheets("liste_a_trier") 'Nom de la feuille contenant le tableau

    'Détermination de la dernière ligne du tableau
    LastRow = wsSource.Cells(Rows.Count, 1).End(xlUp).Row

    'Boucle pour créer un nouveau fichier pour chaque ligne du tableau
    For i = 2 To LastRow 'on commence à la ligne 2 pour exclure la première ligne du tableau
        doublon = Application.WorksheetFunction.CountIf(Range(Cells(2, "A"), Cells(LastRow, "A")), Cells(i, "A"))
        If doublon > 1 Then
            Range(Cells(i, 1), Cells(i + doublon - 1, 40)).Copy
            'Nom du nouveau fichier à partir de la cellule A2
            NewFileName = wsSource.Cells(i, 1).Value & ".xlsx"  'Nom du fichier = "Nom de la cellule A .xlsx"

            'Création d'un nouveau fichier
            Set wbDest = Workbooks.Add
            Set wsDest = wbDest.Sheets("Feuil1")

            'Copie de la plage de cellules correspondant au doublon
            ActiveSheet.Paste

            'Enregistrement et fermeture du nouveau fichier
            DestFolder = "D:\DestFolder\"
            wbDest.SaveAs DestFolder & NewFileName
            wbDest.Close
            i = i + doublon - 1
        End If
    Next i
    'Nettoyage de la mémoire
    Set wbDest = Nothing
    Set wsDest = Nothing

    'Nettoyage de la mémoire
    Set wbSource = Nothing
    Set wsSource = Nothing
End Sub

Cdlt

10000 Mercis

vous êtes un chef