Sub Calcul()
Dim t, d As Object, chemin$, fichier$, titres(), coldeb%, nfich%, n%, tablo, i&, x$, p&, quant(), nn&
t = Timer
Set d = CreateObject("Scripting.Dictionary")
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "*.xls*") '1er fichier du dossier
'---titres---
titres = Array("Article", "Quantités", "Nombre d'années", "Moyenne des quantités")
coldeb = UBound(titres) + 1
While fichier <> ""
If fichier <> ThisWorkbook.Name Then
ReDim Preserve titres(coldeb + nfich) 'base 0
titres(coldeb + nfich) = fichier
nfich = nfich + 1
End If
fichier = Dir
Wend
'---tableau des quantités---
fichier = Dir(chemin & "*.xls*") '1er fichier du dossier
Application.ScreenUpdating = False
While fichier <> ""
If fichier <> ThisWorkbook.Name Then
n = n + 1
With Workbooks.Open(chemin & fichier) 'ouvre le fichier
tablo = .Sheets(1).Cells(1).CurrentRegion.Resize(, 3) 'matrice, plus rapide
For i = 2 To UBound(tablo)
x = Trim(tablo(i, 1))
If x <> "" Then
If Not d.exists(x) Then
p = p + 1
d(x) = p 'mémorise la position
ReDim Preserve quant(1 To nfich, 1 To p)
End If
nn = d(x)
quant(n, nn) = quant(n, nn) + tablo(i, 3)
End If
Next i
.Close False 'ferme le fichier
End With
End If
fichier = Dir 'fichier suivant
Wend
'---restitution---
With Feuil1 'CodeName
If .FilterMode Then .ShowAllData 'si la feuille est filtrée
.Cells.ClearContents 'RAZ
With .[A2] '1ère cellule de destination
.Resize(, coldeb + nfich) = titres
If n * p Then
.Cells(2).Resize(p) = Application.Transpose(d.keys)
.Cells(2, coldeb + 1).Resize(p, n) = Application.Transpose(quant)
.Cells(2, 2).Resize(p) = "=SUM(RC[" & coldeb - 1 & "]:RC[" & coldeb + nfich - 2 & "])"
.Cells(2, 3).Resize(p) = "=COUNT(RC[" & coldeb - 2 & "]:RC[" & coldeb + nfich - 3 & "])"
.Cells(2, 4).Resize(p) = "=RC[-2]/RC[-1]"
.Resize(p + 1, coldeb + n).Sort .Cells(1), xlAscending, Header:=xlYes 'tri sur les articles
End If
End With
.Columns.ColumnWidth = 10.71
.Columns.AutoFit 'ajustement largeurs
End With
Application.ScreenUpdating = True
MsgBox n & " fichiers et " & Format(p, "#,##0") & " articles traités en " & Format(Timer - t, "0.00 \sec")
End Sub