Fast Stack-Columns and Transpose - vba

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

Answer 1

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.

Answer 2

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