Réunir plusieurs fichiers EXCEL dans 1 seul
Résolu/Fermé
A voir également:
- Copier plusieurs fichiers excel dans un seul
- Liste déroulante excel - Guide
- Dessin sms copier coller zizi ✓ - Forum Réseaux sociaux
- Wetransfer gratuit fichiers lourd - Guide
- Renommer plusieurs fichiers - Guide
- Formule excel - Guide
22 réponses
Compiler des fichiers ferméS dans un même répertoire:
Sub compil()
Dim X As Integer, nbFichiers As Integer, Y As Integer
Dim Tableau() As String
Dim Direction As String
Dim rsdata As ADODB.Recordset
Dim szConnect As String
Dim szSQL As String
Dim videderniereligne As String
Dim derniereligne As String
Dim U As Object
Dim feuille As String
Dim i As Integer
'Application.ScreenUpdating = False
'Application.DisplayAlerts = False
Direction = Dir(ThisWorkbook.Path & "\*.xls")
'Direction = Dir(cheminarchivelocal & "*.xls")
Cells.Select
Range("P1").Activate
Selection.ClearContents
Selection.Delete Shift:=xlUp
Do While Len(Direction) > 0
nbFichiers = nbFichiers + 1
ReDim Preserve Tableau(1 To nbFichiers)
Tableau(nbFichiers) = Direction
Direction = Dir()
Loop
If nbFichiers > 0 Then
For X = 1 To nbFichiers
'derniereligne = Worksheets("Feuil1").Range("A5").Rows.Count
If Tableau(X) <> ThisWorkbook.Name Then
'[reportdetailleAZF20070831.xls]Feuil1!$A$2
feuille$ = "zer3_PHA (4)"
'repertoire = "D:\Archivefacturedetc\reportdetaille"
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.Path & "\" & Tableau(X) & ";" & _
"Extended Properties=""Excel 8.0;HDR=yes; IMEX=1"";"
'"Data Source=" & ThisWorkbook.Path & "\" & Tableau(X) & ";" & _
szSQL = "SELECT * FROM [" & feuille & "$]"
Set rsdata = New ADODB.Recordset
rsdata.Open szSQL, szConnect, adOpenForwardOnly, _
adLockReadOnly, adCmdText
''' Vérifie qu'on a bien reçu des données
If Not rsdata.EOF Then
Sheets("Feuil1").Select
If Range("A1").Value = "" Then
Sheets("Feuil1").Range("A1").CopyFromRecordset rsdata
Else:
derniereligne = Worksheets("Feuil1").Range("A3").End(xlDown).Row
videderniereligne = derniereligne + 1
Sheets("Feuil1").Range("A" & videderniereligne).CopyFromRecordset rsdata
End If
End If
End If
Next
Sub compil()
Dim X As Integer, nbFichiers As Integer, Y As Integer
Dim Tableau() As String
Dim Direction As String
Dim rsdata As ADODB.Recordset
Dim szConnect As String
Dim szSQL As String
Dim videderniereligne As String
Dim derniereligne As String
Dim U As Object
Dim feuille As String
Dim i As Integer
'Application.ScreenUpdating = False
'Application.DisplayAlerts = False
Direction = Dir(ThisWorkbook.Path & "\*.xls")
'Direction = Dir(cheminarchivelocal & "*.xls")
Cells.Select
Range("P1").Activate
Selection.ClearContents
Selection.Delete Shift:=xlUp
Do While Len(Direction) > 0
nbFichiers = nbFichiers + 1
ReDim Preserve Tableau(1 To nbFichiers)
Tableau(nbFichiers) = Direction
Direction = Dir()
Loop
If nbFichiers > 0 Then
For X = 1 To nbFichiers
'derniereligne = Worksheets("Feuil1").Range("A5").Rows.Count
If Tableau(X) <> ThisWorkbook.Name Then
'[reportdetailleAZF20070831.xls]Feuil1!$A$2
feuille$ = "zer3_PHA (4)"
'repertoire = "D:\Archivefacturedetc\reportdetaille"
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.Path & "\" & Tableau(X) & ";" & _
"Extended Properties=""Excel 8.0;HDR=yes; IMEX=1"";"
'"Data Source=" & ThisWorkbook.Path & "\" & Tableau(X) & ";" & _
szSQL = "SELECT * FROM [" & feuille & "$]"
Set rsdata = New ADODB.Recordset
rsdata.Open szSQL, szConnect, adOpenForwardOnly, _
adLockReadOnly, adCmdText
''' Vérifie qu'on a bien reçu des données
If Not rsdata.EOF Then
Sheets("Feuil1").Select
If Range("A1").Value = "" Then
Sheets("Feuil1").Range("A1").CopyFromRecordset rsdata
Else:
derniereligne = Worksheets("Feuil1").Range("A3").End(xlDown).Row
videderniereligne = derniereligne + 1
Sheets("Feuil1").Range("A" & videderniereligne).CopyFromRecordset rsdata
End If
End If
End If
Next
