Menu

VBA - A macro to create multi-sheet pivot tables

USFRBR
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

Related