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