title: Fast Stack-Columns and Transpose
body: <p>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.</p>
  <p><strong>Macro</strong></p>
  <pre><code>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 = &quot;Progress: &quot; &amp; i &amp; &quot; of 7589: &quot; &amp; Format(i / 7589, &quot;0%&quot;)
      
      'Copy ID Range
          Sheets(&quot;Opps Closed FY15&quot;).Select
          Range(&quot;A13&quot;).Offset(i, 0).Select
          Set ID = Selection
      'Copy Header Range
          Range(&quot;EX13:HA13&quot;).Select
          Set HeaderSelect = Selection
      'Copy Data Range
          Range(&quot;EX13:HA13&quot;).Offset(i, 0).Select
          Set DataSelect = Selection
      'Select ID and copy it to the next sheet and fill it down
          ID.Copy
          Sheets(&quot;Sheet1&quot;).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(&quot;Opps Closed FY15&quot;).Select
              HeaderSelect.Copy
              Sheets(&quot;Sheet1&quot;).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(&quot;Opps Closed FY15&quot;).Select
              DataSelect.Copy
              Sheets(&quot;Sheet1&quot;).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(&quot;A1:C1&quot;).Offset(56 * (i - 1), 0).Resize(56, 3).Select
          Dim PasteSelect As Range
          Set PasteSelect = Selection
          Range(&quot;D1:F56&quot;).Select
          Selection.Cut Destination:=PasteSelect
          Selection.Resize(1, 1).Offset(0, -1).Select
      End If
      
      Next i
      
      Application.StatusBar = False
  
  End Sub
  </code></pre>
  <p>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...</p>
  <p>any thoughts?</p>
  <h2>Update</h2>
  <p>After yours suggestions i get to tune up a bit the code, I'd like to know if there are others &quot;imperfections&quot;</p>
  <pre><code>Sub pivotsourcedata()
  
      Dim OppsClosed As Worksheet
          Set OppsClosed = Worksheets(&quot;Opps Closed FY15&quot;)
      Dim Shadow2 As Worksheet
          Set Shadow2 = Worksheets(&quot;Shadow2&quot;)
      Dim ID As Range
      Dim ID0 As Range
          Set ID0 = OppsClosed.Range(&quot;A14&quot;)
      Dim HeaderSelect As Range
          Set HeaderSelect = OppsClosed.Range(&quot;EX13:HA13&quot;)
      Dim DataSelect As Range
          Set DataSelect = HeaderSelect
      Dim PasteSelect As Range
      Dim PasteSelect0 As Range
          Set PasteSelect0 = Shadow2.Range(&quot;A1:C1&quot;).Resize(56, 3)
      Dim CopySelect As Range
          Set CopySelect = Shadow2.Range(&quot;D1:F56&quot;)
      Dim Inizialize As Range
          Set Inizialize = Shadow2.Range(&quot;D1:D1&quot;)
      
      '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 = &quot;Progress: &quot; &amp; i &amp; &quot; of 7589: &quot; &amp; Format(i / 7589, &quot;0%&quot;)
      
      '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(&quot;A1&quot;).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                  False, Transpose:=True
              Range(&quot;A1&quot;).Resize(HeaderSelect.Columns.Count).FillDown
          Else
              Range(&quot;D1&quot;).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                  False, Transpose:=True
              Range(&quot;D1&quot;).Resize(HeaderSelect.Columns.Count).FillDown
          End If
  
      'Select the Header, copy it in the adiacent column
          HeaderSelect.Copy
          If i = 1 Then
              Shadow2.Range(&quot;B1&quot;).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
                  False, Transpose:=True
          Else
              Shadow2.Range(&quot;E1&quot;).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(&quot;C1&quot;).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
                      False, Transpose:=True
          Else
                  Shadow2.Range(&quot;F1&quot;).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(&quot;D1:F56&quot;).Cut Destination:=PasteSelect
          End If
      
      Next i
      
      Application.StatusBar = False660858
      'Set ScreenUpdating to True
          Application.ScreenUpdating = True
  
  End Sub
  </code></pre>