Option Compare Database
Sub FusionClasseur()
Dim oFSO, oFl
Dim strepsource, strepdest
Dim tmp As Variant
Dim T As Variant
Dim xlApp1 As Excel.Application
Dim xlApp2 As Excel.Application
Dim xlSheet1 As Excel.Worksheet
Dim xlSheet2 As Excel.Worksheet
Dim xlBook1 As Excel.Workbook
Dim xlBook2 As Excel.Workbook
Dim strPath1 As String
Dim strPath2 As String
Dim i, j, x, y As Long
strepsource = "..." 'répertoire source
strepdest = "..." 'répertoire de destination
Set xlApp1 = CreateObject("Excel.Application")
Set oFSO = CreateObject("Scripting.FileSystemObject")
If oFSO.FolderExists(strepsource) Then
For Each oFl In oFSO.GetFolder(strepsource).Files
Set xlBook1 = xlApp1.Workbooks.Open(strepsource & "\" & oFl.Name)
'On manipule la feuille
Set xlSheet1 = xlBook1.ActiveSheet
'Affecter les données dans tmp
tmp = xlSheet1.Range("A1:Z2000").value
For i = 0 To UBound(tmp, 1)
For j = 0 To UBound(tmp, 2)
For x = 0 To UBound(T, 1) ********
For y = 0 To UBound(T, 2)
While T(x, y) = ""
tmp(i, j) = T(x, y)
Wend
Next y
Next x
Next j
Next i
Erase tmp
Next
End If
'on crée le fichier excel de destination
Set xlApp2 = CreateObject("Excel.Application")
Set xlBook2 = xlApp2.Workbooks.Add
xlBook2.Sheets("Feuil2").Delete
xlBook2.Sheets("Feuil3").Delete
Set xlSheet2 = xlBook2.Worksheets.Add
xlBook2.SaveAs strepdest & "recap.xls"
Set xlBook2 = xlApp1.Workbooks.Open(strepdest & "\" & "recap.xls")
i = 0
While Range("A" & i & "").value = ""
xlSheet2.Range("A" & i & ":Z2000").value = T
i = i + 1
Wend
xlBook2.Save
End Sub
Partager