Consolidate Several Crosstabs into single flat table

antonioroques · May 14th 2016

Hi, I have a worksheet with 90 crosstabs, I'm trying to merge all of them into a consolidated flat table. Researching I found the attached code made by a member named Norie. The example was made for only one crosstab, so I made some changes to allow it to work for all sheets in a workbook. It worked fine, but I have a problem, my crosstabs have 3 row fields and the code was written for a crosstable with only one column field. I dont know how to fix it.

I'm attaching the original code, my modified code, the original crosstab and my crosstab.

Code

Sub OriginalCode()
Dim wsData As Worksheet
Dim wsNew As Worksheet
Dim rngSrc As Range
Dim rngDst As Range
Dim LastCol As Long
Dim LastRow As Long
Dim LastRowDst As Long
Dim I As Long
    
    Set wsData = Worksheets("Sheet1")
    Set wsNew = Worksheets.Add
    
    LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row
    LastRowDst = 2
    LastCol = wsData.Range("IV1").End(xlToLeft).Column
    
    wsNew.Range("A1:C1") = Array("Resources", "Month", "Value")
    For I = 2 To LastRow
        Set rngSrc = wsData.Range("A" & I)
        Set rngDst = wsNew.Range("A" & LastRowDst)
        
        rngSrc.Copy rngDst.Resize(LastCol - 1)
        
        rngSrc.Offset(-(I - 1), 1).Resize(, LastCol - 1).Copy
        rngDst.Offset(0, 1).PasteSpecial Transpose:=True
        rngSrc.Offset(, 1).Resize(, LastCol - 1).Copy
        rngDst.Offset(0, 2).PasteSpecial Transpose:=True
        LastRowDst = LastRowDst + (LastCol - 1)
    Next I
End Sub


Sub MyCode()
    Dim wsData As Worksheet
    Dim wsNew As Worksheet
    Dim rngSrc As Range
    Dim rngDst As Range
    Dim LastCol As Long
    Dim LastRow As Long
    Dim LastRowDst As Long
    Dim I As Long
    Dim x As Long
    Dim OldLastRow As Long
    Dim OldLastRowDest As Long
             
    Set wsNew = Sheets("plantilla")
    
    LastRowDst = 2




    For x = 2 To Sheets.Count
    Set wsData = Worksheets(x)
        
    LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row
    LastRowDst = wsNew.Range("A" & Rows.Count).End(xlUp).Row
    LastCol = wsData.Range("IV1").End(xlToLeft).Column
     
    wsNew.Range("A1:C1") = Array("MainAccount", "Fecha", "Monto")
    For I = 2 To LastRow
        Set rngSrc = wsData.Range("A" & I)
        Set rngDst = wsNew.Range("A" & LastRowDst)
         
        rngSrc.Copy rngDst.Resize(LastCol - 1)
         
        rngSrc.Offset(-(I - 1), 1).Resize(, LastCol - 1).Copy
        rngDst.Offset(0, 1).PasteSpecial Transpose:=True
        rngSrc.Offset(, 1).Resize(, LastCol - 1).Copy
        rngDst.Offset(0, 2).PasteSpecial Transpose:=True
        LastRowDst = LastRowDst + (LastCol - 1)
    Next I
    
    Next x
    
End Sub

Display More

Help is appreciated

MrRedli · May 16th 2016

Re: Consolidate Several Crosstabs into single flat table

hope this helps:

Code

Option Explicit
Sub CreateFlat()
Dim wsData As Worksheet
Dim wsNew As Worksheet
Dim rngSrc As Range
Dim rngDst As Range
Dim LastCol As Long
Dim LastRow As Long
Dim LastRowDst As Long
Dim I As Long
    
    Set wsData = Worksheets("PRESIDENCIA")
    Set wsNew = Worksheets.Add
    
    LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row
    LastRowDst = 2
    LastCol = wsData.Range("IV1").End(xlToLeft).Column
    
    wsNew.Range("A1:e1") = Array("Resources", "cl", "cl2", "Month", "Value")
    For I = 2 To LastRow
        Set rngSrc = wsData.Range("A" & I & ":C" & I)
        Set rngDst = wsNew.Range("A" & LastRowDst)
        
        rngSrc.Copy rngDst.Resize(LastCol - 3)
        
        rngSrc.Offset(-(I - 1), 3).Resize(, LastCol - 3).Copy
        rngDst.Offset(0, 3).PasteSpecial Transpose:=True
        rngSrc.Offset(, 3).Resize(, LastCol - 3).Copy
        rngDst.Offset(0, 4).PasteSpecial Transpose:=True
        LastRowDst = LastRowDst + (LastCol - 3)
    Next I
End Sub

Display More

antonioroques · May 16th 2016

Re: Consolidate Several Crosstabs into single flat table

Quote from MrRedli;770818

hope this helps:

Code

Option Explicit
Sub CreateFlat()
Dim wsData As Worksheet
Dim wsNew As Worksheet
Dim rngSrc As Range
Dim rngDst As Range
Dim LastCol As Long
Dim LastRow As Long
Dim LastRowDst As Long
Dim I As Long
    
    Set wsData = Worksheets("PRESIDENCIA")
    Set wsNew = Worksheets.Add
    
    LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row
    LastRowDst = 2
    LastCol = wsData.Range("IV1").End(xlToLeft).Column
    
    wsNew.Range("A1:e1") = Array("Resources", "cl", "cl2", "Month", "Value")
    For I = 2 To LastRow
        Set rngSrc = wsData.Range("A" & I & ":C" & I)
        Set rngDst = wsNew.Range("A" & LastRowDst)
        
        rngSrc.Copy rngDst.Resize(LastCol - 3)
        
        rngSrc.Offset(-(I - 1), 3).Resize(, LastCol - 3).Copy
        rngDst.Offset(0, 3).PasteSpecial Transpose:=True
        rngSrc.Offset(, 3).Resize(, LastCol - 3).Copy
        rngDst.Offset(0, 4).PasteSpecial Transpose:=True
        LastRowDst = LastRowDst + (LastCol - 3)
    Next I
End Sub

Display More

Ok you are a genius, thanks! I only need a little more help, I tried to convert your code to work with multiple sheets, but when change to the second sheet its all messing. This is the code I used.

Code

Option Explicit
Sub CrearPlantilla()
    Dim wsData As Worksheet
    Dim wsNew As Worksheet
    Dim rngSrc As Range
    Dim rngDst As Range
    Dim LastCol As Long
    Dim LastRow As Long
    Dim LastRowDst As Long
    Dim I As Long
    Dim x As Long
         
    LastRowDst = 2
    Set wsNew = Worksheets("plantilla")
    
    wsNew.Range("A1:e1") = Array("Resources", "CECO", "Location", "MainAcc", "Monto")
    
    For x = 1 To Sheets.Count
         
        Set wsData = Worksheets(x)
             
        LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row
 '       LastRowDst = wsNew.Range("A" & Rows.Count).End(xlUp).Row
        LastCol = wsData.Range("IV1").End(xlToLeft).Column
      




        For I = 2 To LastRow
            Set rngSrc = wsData.Range("A" & I & ":C" & I)
            Set rngDst = wsNew.Range("A" & LastRowDst)
             
            rngSrc.Copy rngDst.Resize(LastCol - 3)
             
            rngSrc.Offset(-(I - 1), 3).Resize(, LastCol - 3).Copy
            rngDst.Offset(0, 3).PasteSpecial Transpose:=True
            rngSrc.Offset(, 3).Resize(, LastCol - 3).Copy
            rngDst.Offset(0, 4).PasteSpecial Transpose:=True
            LastRowDst = LastRowDst + (LastCol - 3)
        Next I
    
    Next x
    
End Sub

Display More

I uploaded a screenshot of the result
[ATTACH=CONFIG]69132[/ATTACH]
Your help is appreciated..

antonioroques · May 16th 2016

Re: Consolidate Several Crosstabs into single flat table

SOLVED! Thanks. The problem I had is that I was using the second sheet with one less row field.

Best Regards,

For anybody interested in the final version is this one. I also attached the file as an example.

Thanks for your help MrRedli

Code

Option Explicit
Sub CreateFlatTable()
    Dim wsData As Worksheet
    Dim wsNew As Worksheet
    Dim rngSrc As Range
    Dim rngDst As Range
    Dim LastCol As Long
    Dim LastRow As Long
    Dim LastRowDst As Long
    Dim i As Long
    Dim x As Long
         
    Set wsNew = Sheets("Consolidated")
    'Clears Consolidated Sheet
    Cells.Select
    Selection.ClearContents
    Range("A1").Select
    '----
    wsNew.Range("A1:E1") = Array("CECO", "Localidad", "MainAcc", "Fecha", "Monto")
    LastRowDst = 2
    
    For x = 2 To Sheets.Count
             
        Set wsData = Sheets(x)
        LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row
        LastCol = wsData.Range("IV1").End(xlToLeft).Column
        
        For i = 2 To LastRow
            Set rngSrc = wsData.Range("A" & i & ":C" & i)
            Set rngDst = wsNew.Range("A" & LastRowDst)
             
            rngSrc.Copy rngDst.Resize(LastCol - 3)
             
            rngSrc.Offset(-(i - 1), 3).Resize(, LastCol - 3).Copy
            rngDst.Offset(0, 3).PasteSpecial Transpose:=True
            rngSrc.Offset(, 3).Resize(, LastCol - 3).Copy
            rngDst.Offset(0, 4).PasteSpecial Transpose:=True
            LastRowDst = LastRowDst + (LastCol - 3)
        Next i




    Next x
End Sub

Display More

Consolidate Several Crosstabs into single flat table

Participate now!

Share