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:

Related

Featured