[XL-2003] fusion de données valeur et format

fusion de données valeur et format

Bonjour,
j'ai un fichier synthèse qui importe par macro des feuilles de données de structure identique depuis plusieurs classeurs. La macro fonctionne bien.
Dans le fichier synthèse, j'ai une autre feuille (feuil7) qui fusionne les données des feuilles importées les unes à la suite des autres sans les lignes vides. Le code utilisé est le suivant et il fonctionne bien aussi :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 Private Sub CommandButton1_Click() Dim i As Long, T() As Variant Application.ScreenUpdating = False Feuil7.Range("a3:L3002").Cells.Clear For i = 1 To Sheets.Count If Sheets(i).Name <> Feuil7.Name Then With Sheets(i) T = .Range("A3:L" & .Range("A" & Rows.Count).End(xlUp).Row).Value Feuil7.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(T, 1), UBound(T, 2)) = T End With End If Next i End Sub
Mon problème est le suivant: la première colonne des données importées est un n° de saisie formaté dans les propriétés des cellules "MTZ-"000 afin que lorsque l'opérateur tape par exemple 6 dans la cellule, cela devient MTZ-006
Ce formatage passe très bien à l'importation avec les codes PasteValues et PasteFormats mais lors de la fusion, il n'y a que la valeur chiffre qui se copie.
Comment modifier mon code pour avoir la fusion des valeurs et des formats ?
Merci

Salut, un exemple de fusion des fichiers XLSX d'un Dossier, à adapter à ton contexte.

Créer une UserForm avec un Label
Code Userform1

Code:

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
Option Explicit
 
Private Sub UserForm_Initialize()
Dim W As Double
 
    With UserForm1
        .StartUpPosition = 2
        .Caption = "Fusion"
        .Height = 86
        .Width = 370
        .BackColor = &H8000000F
        With .Label1
            .Caption = ""
            .TextAlign = fmTextAlignCenter
            .Top = 21
            .Height = 24
            W = UserForm1.Width
            .Width = W - 50
            .Left = UserForm1.Width / 2 - .Width / 2
            .BorderStyle = fmBorderStyleNone
            .ForeColor = &H80000012
            With .Font
                .Name = "Arial"
                .Size = 16
                .Bold = True
            End With
        End With
    End With
End Sub

Dans un Module Standard

Code:

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
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
Private Declare Function QueryPerformanceCounter Lib "kernel32" (x As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (x As Currency) As Boolean
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long
 
Option Explicit
 
Dim TabFichiers() As String
Dim Dep As Currency, Fin As Currency, Freq As Currency
Dim iNumDatas As Long, bFlagNomFeuille As Boolean
Dim iRow As Long, Cpt As Long, NbFichiers As Long
Dim sNum As String, sNomAct As String
Dim LastCol As Long, LettreLastCol As String
Dim LettreColMax As String
 
'   A Adapter
Const sDossierSauvegarde As String = "Sauvegarde Fusions XLSX"
 
Const iRowDep As Long = 1
Const sNomFeuillesDatas As String = "Datas_"
Const TypeFichier As String = "xlsx"
 
Private Function CreationDossier(sDossier) As Long
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Function
 
Private Sub DelFeuilles()
Dim Ws As Worksheet
    For Each Ws In ThisWorkbook.Worksheets
        If (Ws.Name <> ShParam.Name) And (Ws.Name Like sNomFeuillesDatas & "###") Then
            Application.DisplayAlerts = False
            Ws.Delete
            Application.DisplayAlerts = True
        End If
    Next Ws
End Sub
 
Private Sub Init()
    iRow = iRowDep: Cpt = 0
    NbFichiers = 0
    iNumDatas = 0
    sNum = ""
    DelFeuilles
End Sub
 
Private Sub LectureFichiers()
Dim i As Long
    LireEntete TabFichiers(1)
    For i = 1 To UBound(TabFichiers)
        Lire TabFichiers(i)
        Cpt = Cpt + 1
    Next i
End Sub
 
Private Sub Lire(ByVal sNomFichier As String)
Dim FSO As Object
Dim Fichier As String
Dim LastRow As Long
Dim Wkb As Workbook, sNomSh As String
Dim LastRowPaste As Long
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Fichier = FSO.GetFileName(sNomFichier)
 
    UserForm1.Show vbModeless
    UserForm1.Repaint
 
    Application.DisplayAlerts = False
    Set Wkb = Application.Workbooks.Open(sNomFichier, UpdateLinks:=xlUpdateLinksNever, ReadOnly:=True)
    Application.DisplayAlerts = True
 
    LastRow = Wkb.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
    LastRowPaste = iRow + LastRow - iRowDep
 
    If LastRowPaste > ShParam.Rows.Count Or sNum = "" Then
        iRow = iRowDep
        sNomSh = ThisWorkbook.ActiveSheet.Name
        ThisWorkbook.Sheets.Add
 
        iNumDatas = iNumDatas + 1
        sNum = Format(iNumDatas, "000")
 
        With ThisWorkbook
            .ActiveSheet.Name = sNomFeuillesDatas & sNum
            .ActiveSheet.Move After:=.Worksheets(sNomSh)
        End With
        sNomAct = sNomFeuillesDatas & sNum
    End If
 
    Wkb.Worksheets(1).Range("A2:" & LettreLastCol & LastRow).Copy ThisWorkbook.Worksheets(sNomAct).Range("A" & iRow)
    iRow = iRow + LastRow - 1
 
    With Application
        .StatusBar = Space(200) & "Fusion des Fichiers " & UCase$(TypeFichier) & " : " & Cpt + 1 & " / " & NbFichiers
        .CutCopyMode = False
    End With
 
    UserForm1.Label1.Caption = "Fusion des Fichiers " & UCase$(TypeFichier) & " : " & Cpt + 1 & " / " & NbFichiers
    UserForm1.Repaint
 
    Wkb.Close False
    Set FSO = Nothing
End Sub
 
Private Sub LireEntete(ByVal sNomFichier As String)
Dim FSO As Object
Dim Fichier As String
Dim LastRow As Long
Dim Wkb As Workbook, sNomSh As String
Dim LastRowPaste As Long
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Fichier = FSO.GetFileName(sNomFichier)
 
    Application.DisplayAlerts = False
    Set Wkb = Application.Workbooks.Open(sNomFichier, UpdateLinks:=xlUpdateLinksNever, ReadOnly:=True)
    Application.DisplayAlerts = True
 
    LettreColMax = NumCol2Lettre(Application.Columns.Count)
    LastCol = Wkb.Worksheets(1).Range(LettreColMax & "1").End(xlToLeft).Column
    LettreLastCol = NumCol2Lettre(LastCol)
    LastRow = Wkb.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
    LastRowPaste = iRow + LastRow - iRowDep
 
    If LastRowPaste > ShParam.Rows.Count Or sNum = "" Then
        iRow = iRowDep
        sNomSh = ThisWorkbook.ActiveSheet.Name
        ThisWorkbook.Sheets.Add
 
        iNumDatas = iNumDatas + 1
        sNum = Format(iNumDatas, "000")
 
        With ThisWorkbook
            .ActiveSheet.Name = sNomFeuillesDatas & sNum
            .ActiveSheet.Move After:=.Worksheets(sNomSh)
        End With
        sNomAct = sNomFeuillesDatas & sNum
    End If
 
    Wkb.Worksheets(1).Range("A1:" & LettreLastCol & "1").Copy ThisWorkbook.Worksheets(sNomAct).Range("A" & iRow)
    iRow = iRow + 1
 
    Application.CutCopyMode = False
 
    Wkb.Close False
    Set FSO = Nothing
End Sub
 
Private Sub ListeFichiersDossier(sChemin As String, bInclureSousDossiers As Boolean)
Dim FSO As Object, Dossier As Object, Fichier As String
Dim sPath As String
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Dossier = FSO.GetFolder(sChemin)
 
    Fichier = Dir$(sChemin & "\*.*")
    Do While Len(Fichier) > 0
        sPath = sChemin & "\" & Fichier
        If Fichier <> ThisWorkbook.Name And UCase(TypeFichier) = UCase(FSO.GetExtensionName(Fichier)) Then
            NbFichiers = NbFichiers + 1
            ReDim Preserve TabFichiers(1 To NbFichiers)
            TabFichiers(NbFichiers) = sPath
        End If
        Fichier = Dir$()
    Loop
 
    If bInclureSousDossiers Then
        For Each Dossier In Dossier.SubFolders
            ListeFichiersDossier Dossier.Path, True
        Next Dossier
    End If
 
    Set Dossier = Nothing
    Set FSO = Nothing
End Sub
 
Private Sub MepFeuilles()
Dim Ws As Worksheet
    For Each Ws In ThisWorkbook.Worksheets
        If (Ws.Name <> ShParam.Name) And (Ws.Name Like sNomFeuillesDatas & "*") Then
            With Ws
                .Activate
                .Tab.ColorIndex = 19
                .Columns("A:" & LettreColMax).Columns.AutoFit
                .Range("A1").Select
            End With
        End If
    Next Ws
End Sub
 
Private Sub MepFinale()
    With ActiveWindow
        .ScrollRow = 1
        .ScrollColumn = 1
    End With
 
    With ShParam
        .Activate
        .Range("D1").Select
    End With
End Sub
 
Private Function NumCol2Lettre(iNumCol As Long) As String
Dim i As Long, sStr As String
    i = iNumCol
    sStr = ""
    Do While i > 0
        sStr = Chr$(((i - 1) Mod 26) + 65) & sStr
        i = (i - 1) \ 26
    Loop
    NumCol2Lettre = sStr
End Function
 
Sub SaveDatas()
Dim Ws As Worksheet
Dim Wkb As Workbook
Dim sDateSauvegarde As String
Dim sCheminDossierSauvegarde As String
Dim sNomFichier As String
 
    sCheminDossierSauvegarde = ThisWorkbook.Path & "\" & sDossierSauvegarde
    CreationDossier sCheminDossierSauvegarde
 
    Application.ScreenUpdating = False
    For Each Ws In ThisWorkbook.Worksheets
        sDateSauvegarde = Format(Now, "yyyymmdd")
        If Ws.Name Like sNomFeuillesDatas & "###" Then
            sNomFichier = Ws.Name & "_" & sDateSauvegarde & ".xlsx"
            Set Wkb = Workbooks.Add
            Ws.UsedRange.Copy Wkb.Worksheets(1).Range("A1")
            Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs Filename:=sCheminDossierSauvegarde & "\" & sNomFichier, FileFormat:=xlOpenXMLWorkbook
            Application.DisplayAlerts = True
            ActiveWindow.Close
        End If
    Next Ws
 
    With ShParam
        .Activate
        .Range("D1").Select
    End With
 
    Application.ScreenUpdating = True
    Set Wkb = Nothing
End Sub
 
Sub SelDossier()
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "Dossier des XLSX à traiter"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            QueryPerformanceCounter Dep
            Init
            DoEvents
            Application.ScreenUpdating = False
 
            ' Recherche récursive ou non dans les sous dossiers : True/False
            '   ici à False et donc se limitant au dossier racine sélectionné
            ListeFichiersDossier .SelectedItems(1), False
 
            If NbFichiers = 0 Then
                MepFinale
                Application.ScreenUpdating = True
                MsgBox "Pas de fichier XLSX dans " & .SelectedItems(1), vbOKOnly + vbInformation, "Infos"
                ShParam.Range("D1").Select
                Exit Sub
            End If
 
            LectureFichiers
            MepFeuilles
            MepFinale
 
            QueryPerformanceCounter Fin: QueryPerformanceFrequency Freq
 
            With Application
                .ScreenUpdating = True
                .StatusBar = Space(200) & "Fusion terminée : Fichiers  " & Cpt & " / " & Format(((Fin - Dep) / Freq), "0.00 s")
            End With
            UserForm1.Label1.Caption = "Fusion terminée : Fichiers  " & Cpt & " / " & Format(((Fin - Dep) / Freq), "0.00 s")
            UserForm1.Repaint
        End If
 
        With ShParam
            .Activate
            .Range("D1").Select
        End With
    End With
End Sub

Créer 2 Boutons "Formulaire" sur une feuille dont le CodeName sera ShParam
Affecter un des boutons à la procédure SelDossier
Affecter l'autre à la procédure SaveDatas

1 pièce(s) jointe(s)

Bon, j'ai essayé mais je suis confronté à plusieurs obstacles :
- le code est long et compliqué (je ne comprends pas tout, mon niveau étant insuffisant)
- je n'ai pas trouvé comment donner un codename à un bouton contrôle de formulaire
- j'ai du désactiver les lignes 1,2,3 du module standard car je suis sous W7 64 donc je pense que cela doit avoir des répercussions ailleurs.
Merci pour ta proposition mais elle est d'un niveau qui me passe largement au dessus de la tête.
A tout hasard je joins un exemple (très) simplifié de mon fichier où seule la macro de fusion figure car le reste fonctionne.

Salut, W7 64 Bits et Office 64 Bits ?. Dans ce cas lire : Développer avec Office 64 bits

Effectivement W7 et Office 2010 en 64 bits. Je travaille sur le fichier en mode compatibilité car au boulot c'est encore W XP et Office 2003 en 32 bits !

Merci pour le lien. Je vais essayer de me dépatouiller avec cela.:D

Salut, intéresse toi à la compilation conditionnelle, même si dans ton cas il vaudrait bien mieux utiliser la même version que celle de ta boîte.

Bonjour,

Pour "fusionner" format et valeur, c'est la propriété .Text de la cellule qu'il faut copier. Il faut alors travailler cellule par cellule.

Essayez ceci :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
 
Private Sub CommandButton1_Click()
Dim i As Long, T() As Variant
 
    Application.ScreenUpdating = False
    Feuil7.Range("a3:L3002").Cells.Clear
 
    Lig7 = 3    'Feuil 7 alimentée à partir de la ligne 3
 
    For i = 1 To Sheets.Count
        With Sheets(i)
            If .Name <> Feuil7.Name Then
                For Ligne = 3 To .UsedRange.Rows.Count
                    If .Cells(Ligne, 1) <> "" Then  'Ligne non vide si colonne A renseignée
                        For Col7 = 1 To 12          'Colonnes A à L
                            Feuil7.Cells(Lig7, Col7).Value = .Cells(Ligne, Col7).Text
                        Next
                        Lig7 = Lig7 + 1
                    End If
                Next
            End If
        End With
    Next i
End Sub

IMPECCABLE ! cela fonctionne nickel. Encore merci pour cette aide appréciable .:ccool:
Maintenant je vais m'atteler à décortiquer ton code pour en comprendre le complet fonctionnement et le mettre dans mes petits papiers pour le ressortir un jour dans un autre projet.
Petite question : on définit T en début mais on ne le retrouve pas après, donc je pense que je peux l'enlever car cela fonctionne aussi sans.
Merci :D