VBA - A macro to create multi-sheet pivot tables

Ask a question

VBA - A macro to create multi-sheet pivot tables




In this guide we will use of "Dictionary" object, in a two-dimensional array (variable).

The workbook


A workbook regrouping the sales, per month, the salesman and products sold.
The workbook contains 12 sheets, one for each month.
In each of these sheets, three columns:
- Column A: the names of the salesman,
- Column B: the names of products sold,
- Column C: the amount.

The VBA code


To integrate the VBA to your workbook, copy the entire code below.
  • Press ALT + F11
  • Click on Insert/Module
  • Paste the code.

Close the Visual Basic Editor to return to your workbook, then press ALT + F8, select "RécapAvecSommeDesColonnesC" then click "Run."
Change to your convenience:
- The name of the récap sheet
- The "source" columns: A, B and C


<code>Option Explicit

Sub RécapAvecSommeDesColonnesC()
Dim Feuille As Worksheet, i As Long
Dim TablVendeurs(), DicoVendeurs As Object
Dim TablVentes(), DicoVentes As Object
Dim Sommes()

Set DicoVendeurs = CreateObject("Scripting.Dictionary")
Set DicoVentes = CreateObject("Scripting.Dictionary")

'*******REMPLISSAGE DES OBJETS DITIONARY ET VARIABLES*******

'remplissage des étiquettes de lignes et de colonnes sans doublons
For Each Feuille In ThisWorkbook.Worksheets
If Feuille.Name <> "Récap" Then
With Feuille
TablVendeurs = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
For i = LBound(TablVendeurs, 1) To UBound(TablVendeurs, 1)
If Not DicoVendeurs.exists(TablVendeurs(i, 1)) Then DicoVendeurs.Add TablVendeurs(i, 1), TablVendeurs(i, 1)
Next i
TablVentes = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
For i = LBound(TablVentes, 1) To UBound(TablVentes, 1)
If Not DicoVentes.exists(TablVentes(i, 1)) Then DicoVentes.Add TablVentes(i, 1), TablVentes(i, 1)
Next i
End With
End If
Next Feuille
'remplissage de la variable tableau 2D grâce aux clés de Dictionary
ReDim Sommes(1 To DicoVendeurs.Count, 1 To DicoVentes.Count)
For Each Feuille In ThisWorkbook.Worksheets
If Feuille.Name <> "Récap" Then
With Feuille
For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row
Sommes(Application.Match(.Cells(i, 1), DicoVendeurs.keys, 0), Application.Match(.Cells(i, 2), DicoVentes.keys, 0)) = Sommes(Application.Match(.Cells(i, 1), DicoVendeurs.keys, 0), Application.Match(.Cells(i, 2), DicoVentes.keys, 0)) + .Range("C" & i).Value
Next i
End With
End If
Next Feuille

'*******RESTITUTION DES DONNEES*******

With Sheets("Récap")
.Range("A2").Resize(DicoVendeurs.Count, 1) = Application.Transpose(DicoVendeurs.keys)
.Range("B1").Resize(1, DicoVentes.Count) = DicoVentes.keys
.Range("B2").Resize(UBound(Sommes, 1), UBound(Sommes, 2)) = Sommes()
End With
End Sub

</code>

Download Links


You can download the sample sheet:
Jean-François Pillou

CCM is a leading international tech website. Our content is written in collaboration with IT experts, under the direction of Jeff Pillou, founder of CCM.net. CCM reaches more than 50 million unique visitors per month and is available in 11 languages.

Learn more about the CCM team