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
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
| Sub general()
Application.ScreenUpdating = False
'remplit les en-tete
With ThisWorkbook.Sheets(1)
.Cells(1, 1) = "Nom"
.Cells(1, 2) = "Prénom"
.Cells(1, 3) = "Adresse"
.Cells(1, 4) = "Numéro"
.Cells(1, 5) = "Code Postal"
.Cells(1, 6) = "Ville"
.Cells(1, 8) = "Téléphone fixe"
.Cells(1, 7) = "Date de naissance"
.Cells(1, 9) = "Téléphone portable"
.Cells(1, 10) = "Adresse mail"
.Cells(1, 11) = "Carte LAC"
.Cells(1, 12) = "Date d'effet"
End With
'declaration de variable
Dim objFSO As Object
Dim objDossier As Object
Dim objFichier As Object
'initialisation des variables
Set objFSO = CreateObject("Scripting.FileSystemObject")
'definit le repertoire ou se trouvent les feuilles a traiter
Set objDossier = objFSO.GetFolder("C:\Documents and Settings\Labar\Bureau\Nouveau dossier")
'pour chaque classeur dans le répertoire
For Each objFichier In objDossier.Files
'ouvre le classeur
Workbooks.Open objFichier
'lance la méthode copierColler pour toute les cellules a copier
'nom
copierColler "C4", 1
'prenom
copierColler "F4", 2
'adresse
copierColler "C5", 3
'numero de rue
copierColler "G5", 4
'code postal
copierColler "C6", 5
'ville
copierColler "E6", 6
'date de naissance
copierColler "C7", 7
'tel fixe
copierColler "F7", 8
'telephone portable
copierColler "C8", 9
'adresse mail
copierColler "E8", 10
'Carte LAC
copierColler "C9", 11
'Date effet
copierColler "E9", 12
'ferme le classeur client sans sauvegarder
Workbooks(Workbooks.Count).Close saveChanges:=False
Next
'tout ca, c'est pour la mise en forme
'---------------------------------------------------
With ThisWorkbook.Sheets(1)
With .Cells
With .Font
.Name = "Arial"
.Bold = False
.Italic = False
.ColorIndex = 0
.Size = 10
End With
.HorizontalAlignment = xlLeft
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
'---------------------------------------------------
'copie la feuille vers un nouveau classeur
.Copy
End With
'efface les cellules dans thisworkbook
ThisWorkbook.Sheets(1).Cells.Clear
'renome la feuille qui vient d'etre copiée
Workbooks(Workbooks.Count).Sheets(1).Name = "COMMERCIAL"
'enregistre le nouveau classeur dans le repertoire de destination
Workbooks(Workbooks.Count).SaveAs "B:\FICHIER_COMMERCIAL.xls"
'ferme le nouveau classeur
Workbooks(Workbooks.Count).Close
Application.ScreenUpdating = True
End Sub
'méthode qui copie une donnée depuis le classeur client vers thisworkbook
Public Sub copierColler(rangeSource As String, colonneDestination As Integer)
With ThisWorkbook
'si la cellule est vide
If Workbooks(Workbooks.Count).Sheets(2).Range(rangeSource) = "" Then
'on la remplit avec qqc
Workbooks(Workbooks.Count).Sheets(2).Range(rangeSource) = "_"
End If
'copie la cellule depuis le classeur client
Workbooks(Workbooks.Count).Sheets(2).Range(rangeSource).Copy
'colle dans la colonne qui va bien dans thisworkbook
.Sheets(1).Cells(lastRow(.Name, .Sheets(1).Name, colonneDestination) + 1, colonneDestination).PasteSpecial
End With
End Sub
'methode qui permet de connaitre la derniere ligne d'une colonne
Public Function lastRow(leClasseur As String, laFeuille As String, laColonne As Integer)
lastRow = Workbooks(leClasseur).Sheets(laFeuille).Cells(65536, laColonne).End(xlUp).Row
End Function |
