Fusion fichiers Excel

**mea4502** · 05/08/2013, 16h13

Bonjour,

J'ai 4 fichiers dans un dossier. j'ai commencé la macro et j'aimerais que vous m'aidiez à la finaliser.

La macro consiste à récupérer les fichiers et les mettre les uns au dessus des autres. Je vous joins le fichier consolidé et les 4 fichiers à récuperer.

Merci à vous de votre gentillesse

Voici le code ma macro :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub syncronisation_fichier()
 
'Dim Ligne As Long
 
CENTRAL = "SF Hebdo 2.xlsm"
DR1 = "Synthése NB.xlsx"
DR2 = "Synthése NE.xlsx"
DR3 = "Synthése NI.xlsx"
DR4 = "Synthése NS.xlsx"
 
    'GoTo Test
 
    'Choix du dossier contenant les fichiers à consolider
    MsgBox "Choix du dossier contenant les fichiers à consolider"
    Dim Repertoire As FileDialog
    Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
    Repertoire.Show
 
    If Repertoire.SelectedItems.Count > 0 Then
        'Début de la consolidation
        ChDir Repertoire.SelectedItems(1)
        monfichier = Dir("*.*")
 
        While monfichier <> ""
            Workbooks.Open monfichier
 
            monfichier = Dir()
        Wend
    Else
        GoTo ErreurFichier
    End If
 
    'Mise à jour de la Semaine
    Workbooks(CENTRAL).Sheets(1).Range("D8").Value = Workbooks(DR1).Sheets(1).Range("D8").Value
 
    actual_last_row = 17
 
    'Regroupement de la partie 2
    Range(Workbooks(DR1).Sheets(1).Cells(18, 1), Workbooks(DR1).Sheets(1).Cells(Workbooks(DR1).Sheets(1).Cells(18, 1).End(xlDown).Row, 12)).Copy
    Workbooks(CENTRAL).Sheets(1).Activate
    Cells(actual_last_row, 1).Select
 
    ActiveCell.PasteSpecial
 
    actual_last_row = Cells(10000, 1).End(xlUp).Row + 1
 
    Range(Workbooks(DR2).Sheets(1).Cells(18, 1), Workbooks(DR2).Sheets(1).Cells(Workbooks(DR2).Sheets(1).Cells(18, 1).End(xlDown).Row, 12)).Copy
    Workbooks(CENTRAL).Sheets(1).Activate
    Cells(actual_last_row, 1).Select
 
    ActiveCell.PasteSpecial
 
    actual_last_row = Cells(10000, 1).End(xlUp).Row + 1
 
    Range(Workbooks(DR3).Sheets(1).Cells(18, 1), Workbooks(DR3).Sheets(1).Cells(Workbooks(DR3).Sheets(1).Cells(18, 1).End(xlDown).Row, 12)).Copy
    Workbooks(CENTRAL).Sheets(1).Activate
    Cells(actual_last_row, 1).Select
 
    ActiveCell.PasteSpecial
 
    actual_last_row = Cells(10000, 1).End(xlUp).Row + 1
 
    Range(Workbooks(DR4).Sheets(1).Cells(18, 1), Workbooks(DR4).Sheets(1).Cells(Workbooks(DR4).Sheets(1).Cells(18, 1).End(xlDown).Row, 12)).Copy
    Workbooks(CENTRAL).Sheets(1).Activate
    Cells(actual_last_row, 1).Select
 
    ActiveCell.PasteSpecial
 
    actual_last_row = Cells(10000, 1).End(xlUp).Row + 1
 
 
    'Copie partie 3
    For i = 18 To 10000
        If Workbooks(DR1).Sheets(1).Cells(i, 3) = "3)Réalisations des objectifs  qualitatifs et  quantitatifs." Then
            Workbooks(DR1).Sheets(1).Range(Workbooks(DR1).Sheets(1).Cells(i, 3), Workbooks(DR1).Sheets(1).Cells(i + 10, 9)).Copy
            Exit For
        End If
    Next
 
    Workbooks(CENTRAL).Sheets(1).Activate
    Cells(actual_last_row + 1, 3).Select
    ActiveCell.PasteSpecial
 
 
    For i = 18 To 10000
        If Workbooks(DR2).Sheets(1).Cells(i, 3) = "3)Réalisations des objectifs  qualitatifs et  quantitatifs." Then
            Workbooks(CENTRAL).Sheets(1).Cells(actual_last_row + 4, 5) = Workbooks(DR2).Sheets(1).Cells(i + 3, 5).Value
            Workbooks(CENTRAL).Sheets(1).Cells(actual_last_row + 5, 5) = Workbooks(DR2).Sheets(1).Cells(i + 4, 5).Value
            Workbooks(CENTRAL).Sheets(1).Cells(actual_last_row + 6, 5) = Workbooks(DR2).Sheets(1).Cells(i + 5, 5).Value
            Workbooks(CENTRAL).Sheets(1).Cells(actual_last_row + 7, 5) = Workbooks(DR2).Sheets(1).Cells(i + 6, 5).Value
            Workbooks(CENTRAL).Sheets(1).Cells(actual_last_row + 8, 5) = Workbooks(DR2).Sheets(1).Cells(i + 7, 5).Value
            Workbooks(CENTRAL).Sheets(1).Cells(actual_last_row + 9, 5) = Workbooks(DR2).Sheets(1).Cells(i + 8, 5).Value
            Workbooks(CENTRAL).Sheets(1).Cells(actual_last_row + 10, 5) = Workbooks(DR2).Sheets(1).Cells(i + 9, 5).Value
            Workbooks(CENTRAL).Sheets(1).Cells(actual_last_row + 11, 5) = Workbooks(DR2).Sheets(1).Cells(i + 10, 5).Value
            Exit For
        End If
    Next
 
    For i = 18 To 10000
        If Workbooks(DR3).Sheets(1).Cells(i, 3) = "3)Réalisations des objectifs  qualitatifs et  quantitatifs." Then
            Workbooks(CENTRAL).Sheets(1).Cells(actual_last_row + 4, 4) = Workbooks(DR3).Sheets(1).Cells(i + 3, 4).Value
            Workbooks(CENTRAL).Sheets(1).Cells(actual_last_row + 5, 4) = Workbooks(DR3).Sheets(1).Cells(i + 4, 4).Value
            Workbooks(CENTRAL).Sheets(1).Cells(actual_last_row + 6, 4) = Workbooks(DR3).Sheets(1).Cells(i + 5, 4).Value
            Workbooks(CENTRAL).Sheets(1).Cells(actual_last_row + 7, 4) = Workbooks(DR3).Sheets(1).Cells(i + 6, 4).Value
            Workbooks(CENTRAL).Sheets(1).Cells(actual_last_row + 8, 4) = Workbooks(DR3).Sheets(1).Cells(i + 7, 4).Value
            Workbooks(CENTRAL).Sheets(1).Cells(actual_last_row + 9, 4) = Workbooks(DR3).Sheets(1).Cells(i + 8, 4).Value
            Workbooks(CENTRAL).Sheets(1).Cells(actual_last_row + 10, 4) = Workbooks(DR3).Sheets(1).Cells(i + 9, 4).Value
            Workbooks(CENTRAL).Sheets(1).Cells(actual_last_row + 11, 4) = Workbooks(DR3).Sheets(1).Cells(i + 10, 4).Value
            Exit For
        End If
    Next
 
    For i = 18 To 10000
        If Workbooks(DR4).Sheets(1).Cells(i, 3) = "3)Réalisations des objectifs  qualitatifs et  quantitatifs." Then
            Workbooks(CENTRAL).Sheets(1).Cells(actual_last_row + 4, 7) = Workbooks(DR4).Sheets(1).Cells(i + 3, 7).Value
            Workbooks(CENTRAL).Sheets(1).Cells(actual_last_row + 5, 7) = Workbooks(DR4).Sheets(1).Cells(i + 4, 7).Value
            Workbooks(CENTRAL).Sheets(1).Cells(actual_last_row + 6, 7) = Workbooks(DR4).Sheets(1).Cells(i + 5, 7).Value
            Workbooks(CENTRAL).Sheets(1).Cells(actual_last_row + 7, 7) = Workbooks(DR4).Sheets(1).Cells(i + 6, 7).Value
            Workbooks(CENTRAL).Sheets(1).Cells(actual_last_row + 8, 7) = Workbooks(DR4).Sheets(1).Cells(i + 7, 7).Value
            Workbooks(CENTRAL).Sheets(1).Cells(actual_last_row + 9, 7) = Workbooks(DR4).Sheets(1).Cells(i + 8, 7).Value
            Workbooks(CENTRAL).Sheets(1).Cells(actual_last_row + 10, 7) = Workbooks(DR4).Sheets(1).Cells(i + 9, 7).Value
            Workbooks(CENTRAL).Sheets(1).Cells(actual_last_row + 11, 7) = Workbooks(DR4).Sheets(1).Cells(i + 10, 7).Value
            Exit For
        End If
    Next
 
    actual_last_row = actual_last_row + 14
 
    'Copie partie 4
 
    For i = 18 To 10000
        If Workbooks(DR1).Sheets(1).Cells(i, 3) = "4) Obstacles majeurs rencontrés chez les clients." Then
            Workbooks(DR1).Sheets(1).Range(Workbooks(DR1).Sheets(1).Cells(i, 3), Workbooks(DR1).Sheets(1).Cells(i, 9)).Copy
        End If
    Next
 
    Workbooks(CENTRAL).Sheets(1).Activate
    Cells(actual_last_row, 3).Select
    ActiveCell.PasteSpecial
    actual_last_row = actual_last_row + 2

**mea4502** · 05/08/2013, 16h16

Rebonjour,

j'ai quatre fichiers et pour chacun des fichiers, j'ai toujours des parties.
ma macro actuelle me permet de copier pour chacune des parties dans chaque fichier et les mettre les uns au dessus des autres.
J'arrive à faire jusqu'à la partie 3 et j'aimerais faire autant pour les autres parties.

Merci de me repondre et merci de votre gentillesse.

J'attends vos retours

Fusion fichiers Excel

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager