Sub Consolider()
Dim t, chemin$, fichier$, deb As Range, fin As Range, P As Range, Q As Range, a(), Cn As Object, Cd As Object, Rst As Object, n, r As Range, mem, tablo, i%, j%, k&
t = Timer
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "*.xlsx") '1er fichier .xlsx du dossier
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set deb = Sheets("SUIVI").[B7]
Set fin = Sheets("SUIVI").[G7]
Set P = Sheets("SUIVI").[B13:D20,H13:J20,B27:D34,H27:J34,B41:D48]
Union(deb, fin, P) = "" 'RAZ
Set Q = Sheets("Liste bénéficiaires").Range("A11:F" & Rows.Count)
Q.Clear 'RAZ
Set Cn = CreateObject("ADODB.Connection")
Set Cd = CreateObject("ADODB.Command")
Set Rst = CreateObject("ADODB.Recordset")
While fichier <> ""
n = n + 1
Cn.Open = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & chemin & fichier & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1;"""
Cd.ActiveConnection = Cn
'---feuille SUIVI---
Cd.CommandText = "SELECT * FROM [SUIVI$" & deb.Address(0, 0) & ":" & deb.Address(0, 0) & "]"
Rst.Open Cd, , 1, 3
deb.CopyFromRecordset Rst
Rst.Close
Cd.CommandText = "SELECT * FROM [SUIVI$" & fin.Address(0, 0) & ":" & fin.Address(0, 0) & "]"
Rst.Open Cd, , 1, 3
fin.CopyFromRecordset Rst
Rst.Close
For Each r In P.Areas
mem = r
Cd.CommandText = "SELECT * FROM [SUIVI$" & r.Address(0, 0) & "]"
Rst.Open Cd, , 1, 3
r.CopyFromRecordset Rst
Rst.Close
tablo = r 'matrice, plus rapide
For i = 1 To 8
For j = 1 To 3
If IsNumeric(CStr(tablo(i, j))) Then tablo(i, j) = mem(i, j) + tablo(i, j) Else tablo(i, j) = mem(i, j)
Next j, i
r = tablo
Next r
'---feuille Liste bénéficiaires---
For Each r In Q.Rows
Cd.CommandText = "SELECT * FROM [Liste bénéficiaires$" & r.Address(0, 0) & "]"
Rst.Open Cd, , 1, 3
If IsNull(Rst.Fields.Item(0)) Then Exit For
k = k + 1
Q.Rows(k).CopyFromRecordset Rst
Rst.Close
Next r
Cn.Close
fichier = Dir 'fichier suivant
Wend
'---mise en forme---
If k Then
With Q.Resize(k)
.Borders.Weight = xlThin 'bordures
.Columns(2).Resize(, 2).HorizontalAlignment = xlCenter
End With
End If
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox n & " fichier" & IIf(n > 1, "s", "") & " consolidé" & IIf(n > 1, "s", "") & " en " & Format(Timer - t, "0.00 \sec")
End Sub
20 ; H13:J20 ; B27
