Private Sub Worksheet_Activate()
Dim w As Worksheet, a$(), n, tablo, i&
Application.ScreenUpdating = False
Range("A1").CurrentRegion.ClearContents 'RAZ
For Each w In Worksheets
If w.Name <> Me.Name Then
With w.Range("A1").CurrentRegion
ReDim Preserve a(n)
a(n) = .Address(, , xlR1C1, True) 'liste des adresses sources
n = n + 1
tablo = .Resize(, 2)
For i = 1 To UBound(tablo)
tablo(i, 1) = tablo(i, 1) & Chr(1) & tablo(i, 2) 'concaténation avec séparateur
Next i...
Private Sub Worksheet_Activate()
Dim d As Object, w As Worksheet, tablo, i&, x$, a, b, c(), s
Set d = CreateObject("Scripting.Dictionary")
For Each w In Worksheets
If w.Name <> Me.Name Then
tablo = w.[A1].CurrentRegion.Resize(, 3) 'matrice, plus rapide
For i = 2 To UBound(tablo)
If Not UCase(tablo(i, 2)) Like "*TOTAL*" Then
x = tablo(i, 1) & Chr(1) & tablo(i, 2)
d(x) = d(x) + Val(Replace(tablo(i, 3), ",", "."))
End If
Next i
End If
Next w
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2] 'cellule de destination, à adapter
If d.Count Then
a = d.keys: b = d.items: ReDim c(UBound(a), 2) 'base 0
For i = 0 To UBound(a)
s = Split(a(i), Chr(1))
c(i, 0) = s(0)
c(i, 1) = s(1)
c(i, 2) = b(i)
Next
.Resize(d.Count, 3) = c
End If
.Offset(d.Count).Resize(Rows.Count - d.Count - .Row + 1, 3).ClearContents 'RAZ en dessous
End With
With UsedRange
.Cells(.Rows.Count + 1, 2) = "TOTAL"
.Cells(.Rows.Count + 1, 3) = "=SUM(" & .Columns(3).Address(0, 0) & ")"
End With
End Sub
La macro que j'ai donnée pour 4 colonnes (post #4) va très bien pour le fichier du post #6.
Private Sub Worksheet_Activate()
Dim w As Worksheet, a$(), n, tablo, i&
Application.ScreenUpdating = False
Range("A1").CurrentRegion.ClearContents 'RAZ
For Each w In Worksheets
If w.Name <> Me.Name Then
With w.Range("A1").CurrentRegion
ReDim Preserve a(n)
a(n) = .Address(, , xlR1C1, True) 'liste des adresses sources
n = n + 1
tablo = .Resize(, 2)
For i = 1 To UBound(tablo)
tablo(i, 1) = tablo(i, 1) & Chr(1) & tablo(i, 2) 'concaténation avec séparateur
Next i
.Columns(1) = tablo
If n = 1 Then Range("A1") = w.Range("A1")
End With
End If
Next w
Range("A1").Consolidate Sources:=a, Function:=xlSum, TopRow:=True, LeftColumn:=True, CreateLinks:=False 'commande Consolider
Application.DisplayAlerts = False
For Each w In Worksheets
w.Columns(1).TextToColumns w.Columns(1), xlDelimited, Other:=True, OtherChar:=Chr(1) 'commande Convertir
Next w
End Sub