Fast Stack-Columns and Transpose

Question

After few days learning VBA, I managed to get a simple macro to take some data from a sheet and transpose to another, then stack the columns together.

Macro

Sub pivotsourcedata()
    
    Dim HeaderSelect As Range
    Dim DataSelect As Range
    Dim ID As Range
     
    'Variabile Declaration for Progress bar 
        Dim x               As Integer
        Dim MyTimer         As Double


    For i = 1 To 7589
    'Progress bar
        Application.StatusBar = "Progress: " & i & " of 7589: " & Format(i / 7589, "0%")
    
    'Copy ID Range
        Sheets("Opps Closed FY15").Select
        Range("A13").Offset(i, 0).Select
        Set ID = Selection
    'Copy Header Range
        Range("EX13:HA13").Select
        Set HeaderSelect = Selection
    'Copy Data Range
        Range("EX13:HA13").Offset(i, 0).Select
        Set DataSelect = Selection
    'Select ID and copy it to the next sheet and fill it down
        ID.Copy
        Sheets("Sheet1").Select
        If i = 1 Then
        Else
        Selection.Resize(1, 1).Offset(0, 1).Select
        End If
        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True
        Selection.Resize(HeaderSelect.Columns.Count).FillDown
    
    'Select the Header, copy it in the adjacent column    
        Selection.Resize(1, 1).Select
        Selection.Offset(0, 1).Select
        Sheets("Opps Closed FY15").Select
            HeaderSelect.Copy
            Sheets("Sheet1").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
                False, Transpose:=True
                
    'Same for the data, copy to the right of Header        
        Selection.Resize(1, 1).Select
        Selection.Offset(0, 1).Select
        Sheets("Opps Closed FY15").Select
            DataSelect.Copy
            Sheets("Sheet1").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
                False, Transpose:=True
            
    'Stack the columns one over the other 3 by 3.
    ' take the 4th, 5th and 6th columns and stuck'em
    ' below 1st, 2nd and 3rd
    If i = 1 Then
    
    Else
        Range("A1:C1").Offset(56 * (i - 1), 0).Resize(56, 3).Select
        Dim PasteSelect As Range
        Set PasteSelect = Selection
        Range("D1:F56").Select
        Selection.Cut Destination:=PasteSelect
        Selection.Resize(1, 1).Offset(0, -1).Select
    End If
    
    Next i
    
    Application.StatusBar = False

End Sub

As you can see for each of the 7589 times, I copy and transpose 3 times a range of 56 columns. This is taking a while, around 1.5h. Since I need to run it every week, I'm asking if I wrote badly some code portions...maybe I don't know I can seed it up in some areas...

any thoughts?

Update

After yours suggestions i get to tune up a bit the code, I'd like to know if there are others "imperfections"

Sub pivotsourcedata()

    Dim OppsClosed As Worksheet
        Set OppsClosed = Worksheets("Opps Closed FY15")
    Dim Shadow2 As Worksheet
        Set Shadow2 = Worksheets("Shadow2")
    Dim ID As Range
    Dim ID0 As Range
        Set ID0 = OppsClosed.Range("A14")
    Dim HeaderSelect As Range
        Set HeaderSelect = OppsClosed.Range("EX13:HA13")
    Dim DataSelect As Range
        Set DataSelect = HeaderSelect
    Dim PasteSelect As Range
    Dim PasteSelect0 As Range
        Set PasteSelect0 = Shadow2.Range("A1:C1").Resize(56, 3)
    Dim CopySelect As Range
        Set CopySelect = Shadow2.Range("D1:F56")
    Dim Inizialize As Range
        Set Inizialize = Shadow2.Range("D1:D1")
    
    'Variabile Declaration for Progress bar
        Dim x               As Integer
        Dim MyTimer         As Double

    'Set ScreenUpdating to False
        Application.ScreenUpdating = False
    
    For i = 1 To 7589
    'Progress bar
        Application.StatusBar = "Progress: " & i & " of 7589: " & Format(i / 7589, "0%")
    
    'Copy ID Range
        Set ID = ID0.Offset(i, 0)
        
    'Copy Data Range
        Set DataSelect = HeaderSelect.Offset(i, 0)

    'Select ID and copy it to the next sheet and fill it down
        ID.Copy
        Shadow2.Select
        
        If i = 1 Then
            Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                False, Transpose:=True
            Range("A1").Resize(HeaderSelect.Columns.Count).FillDown
        Else
            Range("D1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                False, Transpose:=True
            Range("D1").Resize(HeaderSelect.Columns.Count).FillDown
        End If

    'Select the Header, copy it in the adiacent column
        HeaderSelect.Copy
        If i = 1 Then
            Shadow2.Range("B1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
                False, Transpose:=True
        Else
            Shadow2.Range("E1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
                False, Transpose:=True
        End If
        
                
    'Same for the data, copy to the right of Header
        DataSelect.Copy
        If i = 1 Then
                Shadow2.Range("C1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
                    False, Transpose:=True
        Else
                Shadow2.Range("F1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
                    False, Transpose:=True
        End If
        
            
    'Stack the columns one over the other 3 by 3.
    ' take the 4th, 5th and 6th columns and stuck'em
    ' below 1st, 2nd and 3rd
        If i = 1 Then
        Else
            Set PasteSelect = PasteSelect0.Offset(HeaderSelect.Columns.Count * (i - 1), 0)
            Shadow2.Range("D1:F56").Cut Destination:=PasteSelect
        End If
    
    Next i
    
    Application.StatusBar = False660858
    'Set ScreenUpdating to True
        Application.ScreenUpdating = True

End Sub

The issue is a few thing, but the main issue is all the `.select`, This slows it down and are not needed in most cases. See [THIS](http://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba-macros) for ways to avoid the `.select`. Though a good job using the recorder to learn. — Scott Craner, Dec 16 '15 at 14:53
Thank you @ScottCraner I'll try to get rid of all those select ! I found that using `Application.ScreenUpdating = False` could improve a bit too! — gmeroni, Dec 16 '15 at 15:02
What do you mean transpose and then stack? Do you have an example? — Raystafarian, Dec 16 '15 at 15:29

TPhe · Answer 1 · 2015-12-17T18:00:32.380

Take a look at this link for several other things that you can turn off, such as formula recalculation: http://datapigtechnologies.com/blog/index.php/ten-things-you-can-do-to-speed-up-your-excel-vba-code/ I agree that the multiple selects are unnecessary and likely slowing down the code significantly. In many cases, they can simply be combined - as in using

Selection.Resize(1, 1).Offset(0, 1).Select

instead of

Selection.Resize(1, 1).Select
Selection.Offset(0, 1).Select

But also, why not reference your ranges explicitly using your counter value, and avoid using resize and offset so frequently?

Another thought is to see if you can remove the final operation that stacks the columns after they are pasted to a new sheet - would it be possible to rearrange your source data, perhaps at the top of your macro before you get into the loop? That way you would have to perform that stacking once instead of 7589 times. Or, alternatively, find a way to combine the columns after the end of the loop.

score 0 · Accepted Answer · answered Dec 21 '15 at 15:19

The answer to my question was: "Use arrays" :)

The code now is this:

Sub pivotsourcedata()

    'Set ScreenUpdating to False
        Application.ScreenUpdating = False
        Application.StatusBar = True

    Dim OppsClosed As Worksheet
        Set OppsClosed = Worksheets("Opps Closed FY15")
    Sheets.Add.Name = "Shadow2"
    Dim Shadow2 As Worksheet
        Set Shadow2 = Worksheets("Shadow2")
    Dim ID As Range
    Dim ID0 As Range
        Set ID0 = OppsClosed.Range("A13")
    Dim HeaderSelect As Range
        Set HeaderSelect = OppsClosed.Range("FB1")
    Dim DataSelect As Range
        Set DataSelect = OppsClosed.Range("FC14")

    Dim RowSize As Integer
        OppsClosed.Activate
        Dim lastrow, records, nHeader As Integer
            lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row - 13
            nHeader = 56
            records = lastrow * nHeader


    'Stack DataSelect on column C of Shadow 2
        ReDim TempTableData(1 To nHeader, 1 To lastrow) As Variant
        ReDim TempTableHeader(1 To nHeader, 1 To lastrow)
        ReDim FixedHeaders(1 To nHeader, 1 To 1)
        ReDim Temp_Array1(1 To records, 1 To 1) As Variant
        ReDim Temp_Array2(1 To records, 1 To 1) As Variant
        FixedHeaders = OppsClosed.Range("FC1").Resize(1, nHeader)
        FixedHeaders = Application.Transpose(FixedHeaders)

            For j = 1 To lastrow
            'Progress bar
                    Application.StatusBar = "Progress: " & j & " of " & lastrow & ": " & Format(j / lastrow, "0%")

                For i = 1 To nHeader
                    TempTableData(i, j) = DataSelect.Offset(j - 1, i - 1)
                    TempTableHeader(i, j) = FixedHeaders(i, 1)
                Next i
            Next j

            For j = 1 To nHeader
                For i = 0 To lastrow - 1
                    Temp_Array1((i * nHeader) + j, 1) = TempTableData(j, i + 1)
                    Temp_Array2((i * nHeader) + j, 1) = TempTableHeader(j, i + 1)
                Next i
            Next j

            Shadow2.Range("C1:C" & records).Value2 = Temp_Array1
            Shadow2.Range("B1:B" & records).Value2 = Temp_Array2

        'Copy and Replicate ID
            ReDim TempTableID(1 To records, 1 To 1)
                k = 1

                For i = 1 To records
                    'Progress bar
                    Application.StatusBar = "Progress: " & i & " of " & records & ": " & Format(i / records, "0%")
                    DoEvents

                    'FixedID = OppsClosed.Range("A13").Offset(k, 0)
                    TempTableID(i, 1) = OppsClosed.Range("A13").Offset(k, 0)

                    variable = i / nHeader

                    If Fix(variable) = variable Then
                        k = k + 1
                    End If

                Next i
             Shadow2.Range("A1:A" & records).Value2 = TempTableID



    Application.StatusBar = False
    Application.ScreenUpdating = True

End Sub

This looks much better. What time did you get it down to? I've also had good results with using the dictionary data type, which tends to be much faster than an array but is somewhat different in use and applications. I can't say if it would help in your situation or not, but you may be interested: http://www.snb-vba.eu/VBA_Dictionary_en.html — TPhe, Dec 21 '15 at 16:38
Around 1 minute :)! Much more usable! Now I'm trying to solve another problem, get rid of specific rows based on a condition but seems that arrays don't let to do that -.-' Thanks for the link, i'll look in to it — gmeroni, Dec 21 '15 at 16:42
Well, no need for more optimization, then. I think you could add this filtering into you existing code without too much difficulty - you already have a loop that cycles through a range and adds the values to an array, so just add in an if statement that assess whether or not each row/cell meets you criteria, and only adds it to the array if it passes the logical test. And this is assuming you can't just remove all the values up front - it's always easier to get rid of them before you start looping through row by row. — TPhe, Dec 21 '15 at 16:47

Fast Stack-Columns and Transpose

Update

2 Answers2

Linked