Option Explicit
Sub test()
Dim a, i As Long, w(), n, y, e, v
a = Sheets("2014").Range("b2").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
Set .Item(a(i, 1)) = _
CreateObject("Scripting.Dictionary")
.Item(a(i, 1)).CompareMode = 1
End If
If Not .Item(a(i, 1)).exists(a(i, 3)) Then
ReDim w(1 To 5)
w(1) = a(i, 1): w(2) = a(i, 3): w(3) = a(i, 5)
.Item(a(i, 1))(a(i, 3)) = w
Else
w = .Item(a(i, 1))(a(i, 3))
w(3) = w(3) + a(i, 5)
.Item(a(i, 1))(a(i, 3)) = w
End If
Next
a = Sheets("2015").Range("b2").CurrentRegion.Value
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
Set .Item(a(i, 1)) = _
CreateObject("Scripting.Dictionary")
.Item(a(i, 1)).CompareMode = 1
End If
If Not .Item(a(i, 1)).exists(a(i, 3)) Then
ReDim w(1 To 5)
w(1) = a(i, 1): w(2) = a(i, 3): w(4) = a(i, 5)
.Item(a(i, 1))(a(i, 3)) = w
Else
w = .Item(a(i, 1))(a(i, 3))
w(4) = w(4) + a(i, 5)
.Item(a(i, 1))(a(i, 3)) = w
End If
Next
For Each e In .keys
For Each v In .Item(e).keys
w = .Item(e)(v)
w(5) = w(3) + w(4)
.Item(e)(v) = w
Next
Next
y = .items
End With
'Restitution et mise en forme
Application.ScreenUpdating = False
With Sheets("Feuil1").Cells(1)
.Parent.Cells.Clear
With .Resize(1, 5)
.Value = Array("Nom", "Contrat n°", "2014", "2015", "Total")
.Interior.ColorIndex = 36
.HorizontalAlignment = xlCenter
End With
n = n + .CurrentRegion.Rows.Count
For i = 0 To UBound(y)
With .Offset(n).Resize(y(i).Count, 5)
.Columns(2).NumberFormat = "@"
.Value = _
Application.Transpose(Application.Transpose(y(i).items))
n = n + .Rows.Count + 1
End With
With .Offset(n - 1).Cells(1).Resize(, 5)
.Value = Array("", "Total", _
"=sum(r" & n - y(i).Count & "c:r[-1]c)", _
"=sum(r" & n - y(i).Count & "c:r[-1]c)", _
"=sum(r" & n - y(i).Count & "c:r[-1]c)")
.Interior.ColorIndex = 44
End With
Next
With .CurrentRegion
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
With .Offset(1).Resize(.Rows.Count - 1)
.Columns("c:e").NumberFormat = "#,##0.00"
End With
End With
.Parent.Activate
End With
Application.ScreenUpdating = True
End Sub
Option Explicit
Sub test()
Dim a, b(), w(), y, e, v
Dim ws As Worksheet, i As Long, n As Long, t As Byte, ub As Byte
If ActiveWindow.SelectedSheets.Count > 1 Then
ub = ActiveWindow.SelectedSheets.Count + 3
ReDim b(1 To ub): n = 2
For Each ws In ActiveWindow.SelectedSheets
n = n + 1: b(n) = ws.Name
Next ws
b(1) = "Nom": b(2) = "Contrat n°": b(ub) = "Total"
With CreateObject("Scripting.Dictionary")
.CompareMode = 1: t = 2
For Each ws In ActiveWindow.SelectedSheets
a = Sheets(ws.Name).Range("b2").CurrentRegion.Value
t = t + 1
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
Set .Item(a(i, 1)) = _
CreateObject("Scripting.Dictionary")
.Item(a(i, 1)).CompareMode = 1
End If
If Not .Item(a(i, 1)).exists(a(i, 3)) Then
ReDim w(1 To ub)
w(1) = a(i, 1): w(2) = a(i, 3): w(t) = a(i, 5)
.Item(a(i, 1))(a(i, 3)) = w
Else
w = .Item(a(i, 1))(a(i, 3))
w(t) = w(t) + a(i, 5)
.Item(a(i, 1))(a(i, 3)) = w
End If
Next
Next
For Each e In .keys
For Each v In .Item(e).keys
w = .Item(e)(v)
w(UBound(w)) = Application.Sum(Application.Index(w, Evaluate("row(3:" & UBound(w) - 1 & ")")))
.Item(e)(v) = w
Next
Next
y = .items
End With
'Restitution et mise en forme
Application.ScreenUpdating = False
With Sheets("Feuil1").Cells(1)
.Parent.Cells.Clear: n = 0
With .Resize(1, ub)
.Value = b
.Interior.ColorIndex = 36
.HorizontalAlignment = xlCenter
End With
n = n + .CurrentRegion.Rows.Count
For i = 0 To UBound(y)
With .Offset(n).Resize(y(i).Count, ub)
.Columns(2).NumberFormat = "@"
.Value = _
Application.Transpose(Application.Transpose(y(i).items))
n = n + .Rows.Count + 1
End With
With .Offset(n - 1)
.Cells(1, 1).Resize(, ub).Interior.ColorIndex = 42
.Cells(1, 2).Value = "Total"
.Cells(1, 3).Formula = "=sum(r" & n - y(i).Count & "c:r[-1]c)"
.Cells(1, 3).AutoFill .Cells(1, 3).Resize(, ub - 2)
End With
Next
With .CurrentRegion
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
With .Offset(1, 2).Resize(.Rows.Count - 1, .Columns.Count - 2)
.NumberFormat = "#,##0.00"
End With
End With
.Parent.Activate
End With
Application.ScreenUpdating = True
Else
MsgBox "Vous devez sélectionner au moins 2 feuilles"
End If
End Sub
Private Sub UserForm_Initialize()
Dim ws As Worksheet
With ListBox1
.MultiSelect = fmMultiSelectMulti
For Each ws In Worksheets
If ws.Name <> "cumul" Then
.AddItem ws.Name
End If
Next ws
End With
End Sub
Private Sub CommandButton1_Click()
Dim Tablo(), n As Byte
Me.Hide
With Me.ListBox1
For i = 0 To .ListCount - 1
If .Selected(i) = True Then
n = n + 1
ReDim Preserve Tablo(1 To n)
Tablo(n) = .List(i, 0)
.Selected(i) = False
End If
Next
End With
If n > 0 Then
Unload Me
Call test1(Tablo)
Else
MsgBox "Vous devez sélectionner au moins 1 feuille"
Me.Show
End If
End Sub
Option Explicit
Sub test1(Tablo())
Dim a, b(), w(), y, e, v
Dim i As Long, n As Long, t As Byte, ub As Byte
ub = UBound(Tablo) + 3
ReDim b(1 To ub): n = 2
For Each e In Tablo
n = n + 1: b(n) = e
Next
b(1) = "Nom": b(2) = "Contrat n°": b(ub) = "Total"
With CreateObject("Scripting.Dictionary")
.CompareMode = 1: t = 2
For Each e In Tablo
a = Sheets(e).Range("b2").CurrentRegion.Value
t = t + 1
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
Set .Item(a(i, 1)) = _
CreateObject("Scripting.Dictionary")
.Item(a(i, 1)).CompareMode = 1
End If
If Not .Item(a(i, 1)).exists(a(i, 3)) Then
ReDim w(1 To ub)
w(1) = a(i, 1): w(2) = a(i, 3): w(t) = a(i, 5)
.Item(a(i, 1))(a(i, 3)) = w
Else
w = .Item(a(i, 1))(a(i, 3))
w(t) = w(t) + a(i, 5)
.Item(a(i, 1))(a(i, 3)) = w
End If
Next
Next
For Each e In .keys
For Each v In .Item(e).keys
w = .Item(e)(v)
w(UBound(w)) = Application.Sum(Application.Index(w, Evaluate("row(3:" & UBound(w) - 1 & ")")))
.Item(e)(v) = w
Next
Next
y = .items
End With
'Restitution et mise en forme
Application.ScreenUpdating = False
With Sheets("Cumul").Cells(1)
.Parent.Cells.Clear: n = 0
With .Resize(1, ub)
.Value = b
.Interior.ColorIndex = 36
.HorizontalAlignment = xlCenter
End With
n = n + .CurrentRegion.Rows.count
For i = 0 To UBound(y)
With .Offset(n).Resize(y(i).count, ub)
.Columns(2).NumberFormat = "@"
.Value = _
Application.Transpose(Application.Transpose(y(i).items))
n = n + .Rows.count + 1
End With
With .Offset(n - 1)
.Cells(1, 1).Resize(, ub).Interior.ColorIndex = 42
.Cells(1, 2).Value = "Total"
.Cells(1, 3).Formula = "=sum(r" & n - y(i).count & "c:r[-1]c)"
.Cells(1, 3).AutoFill .Cells(1, 3).Resize(, ub - 2)
End With
Next
With .CurrentRegion
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
With .Offset(1, 2).Resize(.Rows.count - 1, .Columns.count - 2)
.NumberFormat = "#,##0.00"
End With
End With
'.Parent.Activate
End With
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton1_Click()
UserForm1.Show
End Sub