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
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
| Sub MacroProposée()
'on va changer le type d'extension par défaut pour que la macro fonctionne même
'si tes réglages par défaut sont différents des miens :
Dim TypeExtention As Integer
TypeExtention = Application.DefaultSaveFormat
Application.DefaultSaveFormat = 51 'pour avoir par défaut .xlsx
'on dimensionne tout le bazar
Dim wbPrincipal As Workbook
Dim wbSecondaire As Workbook
Dim cell As Range
Dim Extension As String, NomFichier As String, CheminDossier As String, CheminFichier As String
'On affecte les variables
Set wbPrincipal = ActiveWorkbook
Extension = ".xlsx"
CheminDossier = "C:\Exemple\" 'Mets ici le chemin de ton dossier où tu veux créer les fichiers
If Right(CheminDossier, 1) <> "\" And Right(CheminDossier, 1) <> "/" Then
CheminDossier = CheminDossier & "\" 'cela mettra le \ si tu as oublié de le spécifier plus haut
End If
'On va 'scanner' la première colonne de ta liste. ELLE DOIT ETRE EN PREMIERE FEUILLE ET COMMENCER EN A1, sinon tu adaptes.
For Each cell In wbPrincipal.Sheets(1).Range("A:A").SpecialCells(xlCellTypeConstants)
NomFichier = Trim(cell.Text) 'la fonction Trim va supprimer les éventuels espaces au début et à la fin du contenu de la cellul
CheminFichier = CheminDossier & NomFichier & Extension 'on construit le nom du fichier à partir des infos que l'on a
'ici on va vérifier si le fichier existe :
'la fonction Dir(chemin) retourne le nom du fichier s'il existe, sinon ne retourne rien, donc des guillemets vides("")
Select Case Dir(CheminFichier)
Case NomFichier & Extension 's'il a bien trouvé le fichier
Set wbSecondaire = Workbooks.Open(CheminFichier)
Case "" '(ou else ou vbnullstring) s'il n'a rien trouvé
Set wbSecondaire = Workbooks.Add
wbSecondaire.Sheets(1).Range("A1").Value = "Nom et prénom"
wbSecondaire.Sheets(1).Range("B1").Value = "Pays"
wbSecondaire.Sheets(1).Range("C1").Value = "Téléphone"
wbSecondaire.Sheets(1).Range("D1").Value = "Info"
wbSecondaire.SaveAs CheminFichier
End Select
'Peu importe qu'on l'ait créé maintenant ou juste ouvert, on rajoute une ligne :
With wbSecondaire.Sheets(1).Range("A" & Rows.Count).End(xlUp)
.Offset(1, 0).Value = cell.Value
.Offset(1, 1).Value = cell.Offset(0, 1).Value
.Offset(1, 2).Value = cell.Offset(0, 2).Value
.Offset(1, 3).Value = cell.Offset(0, 3).Value
End With
wbSecondaire.Save
wbSecondaire.Close SaveChanges = True 'Dans tous les cas on le ferme et on sauvegarde les modifs
Set wbSecondaire = Nothing 'facultatif : on vide la variable objet
Next cell
Application.DefaultSaveFormat = TypeExtension 'on remet ce réglage comme avant la macro
End Sub |
Macro création de classeur en fonction d'un nom + copie des bonnes données
Répondre avec citation
Donc j'ai fait un .Save juste avant, ça fait répétition mais ça fonctionnera à coup sûr !
Envoyé par Quentin77170
Partager