Macro à compléter

Bonsoir,

J’ai créé une macro qui fait en sorte que chaque fois que le nom de l’agent change (colonne A), la macro crée un nouveau fichier au nom de cet agent. Jusque-là tout va bien.

Je suis par contre incapable de conserver les en-têtes des colonnes (A1:F1). J’aimerais aussi que la macro modifie le nom de l’onglet (Jean au lieu de Feuil1 dans le premier fichier par exemple). J’aimerais pousser ma luck au point de spécifier en emplacement de sauvegarde pour les fichiers.

Merci beaucoup tout le monde.

Bonjour,

Votre macro modifiée:

Sub CreerNouveauxFichiers()
    Dim ws As Worksheet
    Dim rng As Range
    Dim agentName As String
    Dim newWorkbook As Workbook
    Dim newRow As Range
    Dim tbl As ListObject
    Dim i As Integer
    Dim Titres As Variant, Chemin As Variant

    Application.ScreenUpdating = False

    Set ws = ThisWorkbook.Sheets("Feuil1") ' Remplacez "Feuil1" par le nom de votre feuille
    lastRow = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row ' Trouvez la dernière ligne dans la colonne W
    Set rng = ws.Range("A2:f" & lastRow) ' Définissez votre plage en utilisant la dernière ligne trouvée

    agentName = rng.Cells(1, 1).Value ' Nom du premier agent
    Set newWorkbook = Workbooks.Add ' Créez un nouveau classeur

    ' Créez un tableau dans le nouveau classeur
    Set tbl = newWorkbook.Sheets(1).ListObjects.Add(xlSrcRange, newWorkbook.Sheets(1).Range("A1").Resize(1, rng.Columns.Count), , xlYes)
    tbl.Name = "TableauAgent"
    Titres = Array("Nom de l'agent", "Âge", "Statut d'assignation", "Assigné le", "Urgent", "Statut")
    For i = 0 To UBound(Titres)
        If i < tbl.ListColumns.Count Then
            tbl.ListColumns(i + 1).Name = Titres(i)
        End If
    Next i

    'Emplacement de destination des nouveaux fichiers
    Chemin = "C:\Users\Documents\" 'mettre ici l'emplacement de destination de vos fichiers

    For Each newRow In rng.Rows
        If newRow.Cells(1, 1).Value <> agentName Then
            ' Le nom de l'agent a changé, enregistrez le nouveau fichier
            newWorkbook.SaveAs Chemin & agentName & ".xlsx"
            ActiveWorkbook.Close
            agentName = newRow.Cells(1, 1).Value
            Set newWorkbook = Workbooks.Add
            ' Créez un nouveau tableau dans le nouveau classeur
            Set tbl = newWorkbook.Sheets(1).ListObjects.Add(xlSrcRange, newWorkbook.Sheets(1).Range("A1").Resize(1, rng.Columns.Count), , xlYes)
            tbl.Name = "TableauAgent"
            For i = 0 To UBound(Titres)
                If i < tbl.ListColumns.Count Then
                    tbl.ListColumns(i + 1).Name = Titres(i)
                End If
            Next i
        End If
        newRow.Copy tbl.ListRows.Add.Range
    Next newRow

    ' Enregistrez le dernier fichier
    newWorkbook.SaveAs Chemin & agentName & ".xlsx"
    ActiveWorkbook.Close
End Sub

Il ne vous reste qu'à indiquer le Chemin de destination des fichiers à la ligne:

 Chemin = "C:\Users\Documents\" 'mettre ici l'emplacement de destination de vos fichiers)

Cdlt

Merci Arturo83, ça fonctionne nickel.

Si je veux que les colonnes des nouveaux fichiers s'ajuste automatiquement à la bonne largeur, est-ce possible de simplement ajouter une ligne de code? Si oui laquelle?

Bonjour,

Copiez cette ligne de code

Columns("A:G").EntireColumn.AutoFit

juste avant les lignes (attention, il y en a 2):

newWorkbook.SaveAs Chemin & agentName & ".xlsx"

Cdlt

Passez le sujet en "Résolu" si cela vous convient.

Merci ça fonctionne très bien. J'ai encore un autre trouble.

Le code en attaché renomme les fichiers déjà dans un dossier, mais le nom du nouveau fichier DOIT débuter par D, ce qui fait que si j'ai certains fichiers à renommer qui débute par la lettre F, la macro ne se rends pas. En renommant le fichier la 1ere lettre deviens D, en les classant en ordre alphabétique, tant que les fichiers débute par une autre lettre avant D tout va bien.

Exemple: Avant le fichier se nomme "cadeau", après la macro il se nomme "Dcadeau". Le fichier qui se nomme avant "photo" ne pourra jamais être renommé car la macro va voir Dcadeau et va le renommer encore une fois mais cette fois DcadeauDcadeau, et ainsi de suite. À un certain moment la macro plante tout simplement.

J'ai pensé aussi simplement dire à la macro qu'une fois le fichier renommer de le déplacer dans un autre dossier, mais mes tentatives de programmation furent vaines.

Merci beaucoup.

Bonjour,

Il suffit de tester la première lettre du fichier, si c'est un "D" on passe au fichier suivant, sinon on exécute le changement de nom.

Sub RenommerFichiers()
    Dim Chemin As String
    Dim Fichier As String
    Dim NouveauNom As String

    ' Spécifiez le chemin du répertoire contenant les fichiers à renommer
    Chemin = "C:\Users\mosaidso\"

    ' Boucle à travers tous les fichiers dans le répertoire
    Fichier = Dir(Chemin & "*.xlsx") ' Remplacez "*.xlsx" par le masque de fichier souhaité
    Do While Fichier <> ""
        If Left(Fichier, 1) <> "D" Then
           ' Déterminez le nouveau nom pour chaque fichier (par exemple, ajoutez un préfixe)
           NouveauNom = "D" & Fichier
           ' Renommez le fichier
           Name Chemin & Fichier As Chemin & NouveauNom
        End If
        ' Passez au fichier suivant
        Fichier = Dir
    Loop
End Sub

Cdlt

Merci beaucoup ça fonctionne nickel