Bonjour à tous,

Je cherche à consolider des exports (onglet"Data") (nombre variables comprenant 10 000 lignes environ chaque) qui sont situé sur un lecteur reseau dans un autre fichier RECAP sur l'onglet "DataConso".

J'essaie pas mal de chose mais je n'arrive pas à trouver le bon code et l'adapter à ma situation.

Quelqu'un pourrait il m'aider à avancer?

Merci d'avance

Voici les différents code que j'ai trouvé:

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
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
Option Explicit
Sub test()
Dim MonRepertoire As String, fso As Object, f As Object, i As Integer
Set fso = CreateObject("Scripting.FileSystemObject")
MonRepertoire = "H:\AUTRE\SOPHIE\BASE GAD\EXTRACTION\"
For Each f In fso.GetFolder(MonRepertoire).Files
    If Right(f.Name, 4) = ".xls" Then Workbooks.Open MonRepertoire & f.Name
Next f
End Sub
 
 
Sub ouvrir()
Dim Fichier As String
Dim Chemin As String
Dim Fichier_Recap As String
Dim wb As Workbook
Dim ws As Worksheet
Application.ScreenUpdating = False
'ChDir ActiveWorkbook.Path
 
Fichier_Recap = ActiveWorkbook.Name
 
    'Définit le répertoire contenant les fichiers
    Chemin = "H:\AUTRE\SOPHIE\BASE GAD\EXTRACTION\"
 
    'Boucle sur tous les fichiers xls du répertoire.
Fichier = Dir(Chemin & "*.xlsx")
Fichier = Dir("*.xls")
If Fichier = "" Then Exit Sub
Do Until Fichier = ""
    If Fichier <> Fichier_Recap Then
        Workbooks.Open Fichier
        Workbooks(Fichier).Sheets("base").Copy After:=Workbooks(Fichier_Recap).Sheets(1)
        Workbooks(Fichier).Close
    End If
    Fichier = Dir
Loop
End Sub
 
 
Sub ouvrir_avec_mdp()
Dim Fichier As String
Dim Fichier_Recap As String
Application.ScreenUpdating = False
ChDir ActiveWorkbook.Path
Fichier_Recap = ActiveWorkbook.Name
Fichier = Dir("*.xls")
If Fichier = "" Then Exit Sub
Do Until Fichier = ""
    If Fichier <> Fichier_Recap Then
        Workbooks.Open Fichier, Password:="cdg"
        Workbooks(Fichier).Sheets("base").Copy After:=Workbooks(Fichier_Recap).Sheets(1)
        Workbooks(Fichier).Close
    End If
    Fichier = Dir
Loop
End Sub
 
Sub Ouvrir_Fichiers()
' Permet d'ouvrir plusieurs fichiers dans un répertoire
' GC Excel - 2011-11-16
 
Dim wb As Workbook, wb2 As Workbook
Dim sPath As String, sFilename As String
Dim NbRows As Integer, rg As Range
 
Set wb = ThisWorkbook
 
Application.ScreenUpdating = False
 
sPath = "H:\AUTRE\SOPHIE\BASE GAD\EXTRACTION\"       'Répertoire
sFilename = Dir(sPath & "*.xls*")        'ouvre tous les fichiers .xls*
 
Do While Len(sFilename) > 0
Set wb2 = Workbooks.Open(sPath & sFilename)           'Ouvre le fichier
'
' Votre code ici
    NbRows = wb2.Sheets(2).Range("A60000").End(xlUp).Row  'Nb de lignes
Set rg = wb.Sheets(2).Range("A60000").End(xlUp).Offset(1, 0)
    rg = sFilename
    rg.Offset(0, 1) = NbRows
'
'
    wb2.Close False   'Fermer le fichier
    sFilename = Dir
 
Loop
Application.ScreenUpdating = True
 
End Sub
 
 
 
'------------------------------------------------------------------------------
' Macro qui permet de compiler les informations contenues dans
' différents fichier pour les regrouper dans un fichier récapitulatif
' GCXL
'-------------------------------------------------------------------------------
Sub Creer_Recapitulatif()
Dim wbRecap As Workbook         'fichier recap
Dim wsRecap As Worksheet        'feuille où on écrit les données
Dim wbSource As Workbook        'fichier à ouvrir
Dim wsSource As Worksheet       'feuille où on cherche les données
Dim DernLign As Integer         'ligne où on écrit les données
Dim vFichiers As Variant        'noms des fichiers
Dim i As Integer, k As Integer
Dim rgRecap As Range            'plage où on copie les données
 
Set wbRecap = ThisWorkbook    'Fichier récapitulatif
Set wsRecap = wbRecap.Sheets("Data")  'on écrit dans la feuille DATA du fichier récapitulatif
 
' --- Ouvrir boite de dialogue pour sélectionner les fichiers à ouvrir
    vFichiers = Selectionner_Fichiers("Sélectionner les fichiers à compiler") 'Appel de Fonction pour ouvrir fichiers
 
' --- Vérifier qu'au moins un fichier à été sélectionné
If Not IsArray(vFichiers) Then
        Debug.Print "Aucun fichier sélectionné."
        MsgBox "Erreur! Aucun/Mauvais fichier sélectionné."
Exit Sub
End If
On Error Resume Next
 
    Application.ScreenUpdating = False
 
' --- Boucle à travers les fichiers
For k = 1 To UBound(vFichiers)
        Application.StatusBar = ">> Lecture du fichier #" & k & "/" & UBound(vFichiers)
 
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' C'est ici qu'on écrit les instructions
Set wbSource = Workbooks.Open(vFichiers(k))                        'on ouvre le fichier
Set wsSource = wbSource.Sheets(2)                                  'On copie les données de la feuille 1
        DernLign = wbRecap.Sheets(2).Range("A60000").End(xlUp).Row + 1     'ligne pour écrire le log des fichiers compilés
 
' - On copie les données vers le fichier Recapitulatif; à adapter
Set rgRecap = wsRecap.Range("A65000").End(xlUp).Offset(1, 0)
      '  rgRecap = Time
 
      wsSouce.Range("A1:AJ" & DerniereLigne).Copy
'With wsSource
        wsRecap.Range("A" & rgRecap).Select
 
             Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 '           rgRecap.Offset(0, 2) = .Range("B8")
  '          rgRecap.Offset(0, 3) = .Range("B10")
  '          rgRecap.Offset(0, 4) = .Range("B13")
    '        rgRecap.Offset(0, 5) = .Range("B14")
'End With
 
        wbSource.Close              'fermer fichier
Set wbSource = Nothing
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Next k
 
    Application.ScreenUpdating = True
    Application.StatusBar = False
 
End Sub '------------------------------------------------------------------------------
 
 
Function Selectionner_Fichiers(sTitre As String) As Variant
Dim sFiltre As String, bMultiSelect As Boolean
 
    sFiltre = "Fichiers XYZ (.xls)(.xlsm), *.xls*"
    bMultiSelect = True 'Permet de choisir plusieurs fichiers à la fois
    Selectionner_Fichiers = Application.GetOpenFilename(Filefilter:=sFiltre, Title:=sTitre, MultiSelect:=bMultiSelect)
End Function