Stack columns for large datasets (slow code) + run down to blank cell

[lerrokrednas]

Dear forum,

I'm looking for a clean and light way to transform the way my data is stated. I succeeded in writing a code to stack several columns on top of another, running from the first row downwards to the first blank cell and jumping to the next column.

As is shown in the table below, the number of observations is quite large, which makes my current VBA-code very slow (also shown below). Also, the code works like a charm when run on a separate sheet (also with even larger datasets it takes 5 seconds), but when I run the code like I have now, it takes about 4 minutes.

The output of the database looks as follows:

Table 1

05/07/16	08/10/18	...	These are dates
06/07/16	09/10/18	...	→ ±1000 observations
...	...	...	↓ ±200 observations
130.05	250.30	...	These are stock prices
132.20	251.34	...	→ ±1000 observations
...	...	...	↓ ±200 observations
2,088.20	2,109.03	...	These are market prices
2,090.54	2,120.10	...	→ ±1000 observations
...	...	...	↓ ±200 observations

<tbody>
</tbody>

In the data shown above I already put in some blank rows between the different types of observations in order to let the code (see below) run downwards until a blank cell appears and jumps to the next column.

What I'm trying to achieve is something that looks like this:

Table 2

05/07/16	130.05	2,088.20
06/07/16	132.20	2,090.54
...	...	...
08/10/18	200.30	2,109.03
09/10/18	201.34	2,120.10
...	...	...

<tbody>
</tbody>

The code I'm currently using is the following:

<style type="text/css">p.p1 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo}span.s1 {color: #011993}</style>Application.ScreenUpdating = False
Application.Calculation = xlManual

'** Here I copy the cells from the output to another (newly created before this section) sheet to perform 'stacking'.
'** Because the final dataset to perform this action for is quite large, I tested the action for 30 columns and 125 observations. 
<style type="text/css">p.p1 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo}p.p2 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; min-height: 13.0px}p.p3 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; color: #011993}span.s1 {color: #008f00}span.s2 {color: #011993}span.s3 {color: #000000}</style>Worksheets("Sheet1").Range("B6:AE131").Copy Destination:=Worksheets("Dates").Range("B1")
Worksheets("Sheet1").Range("B132:AE257").Copy Destination:=Worksheets("StockPrices").Range("B1")
Worksheets("Sheet1").Range("B258:AE383").Copy Destination:=Worksheets("MarketPrice").Range("B1")

'** Here the loop starts to 'stack' the columns on top of each other in column A.
'** This is where I think the real jam is.
Worksheets("Dates").Activate
Set ws = ActiveSheet
        Do Until ws.Cells(1, 2).Value = ""
            Set rngCopy = ws.Range("B2", ws.Cells(ws.Rows.Count, "B").End(xlUp))
            Set rngEnd = ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1, 0)
                  rngEnd.Resize(rngCopy.Rows.Count, 1).Value = rngCopy.Value
                  rngCopy.EntireColumn.Delete
    Loop

Worksheets("StockPrices").Activate
    Set ws = ActiveSheet
        Do Until ws.Cells(1, 2).Value = ""
            Set rngCopy = ws.Range("B2", ws.Cells(ws.Rows.Count, "B").End(xlUp))
            Set rngEnd = ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1, 0)
                  rngEnd.Resize(rngCopy.Rows.Count, 1).Value = rngCopy.Value
                  rngCopy.EntireColumn.Delete
    Loop

Worksheets("MarketPrice").Activate
    Set ws = ActiveSheet
        Do Until ws.Cells(1, 2).Value = ""
            Set rngCopy = ws.Range("B2", ws.Cells(ws.Rows.Count, "B").End(xlUp))
            Set rngEnd = ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1, 0)
                  rngEnd.Resize(rngCopy.Rows.Count, 1).Value = rngCopy.Value
                  rngCopy.EntireColumn.Delete
    Loop

<style type="text/css">p.p1 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo}p.p2 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; min-height: 13.0px}p.p3 {margin: 0.0px 0.0px 0.0px 0.0px; font: 11.0px Menlo; color: #008f00}span.s1 {color: #011993}</style>Application.Calculation = xlAutomatic
Application.ScreenUpdating = True

Subsequently, after running this part, I copy these cells to the output sheet.

As you see, I perform the action on separate sheets, which I think may slow down the process heavily. I thought a solution might be to insert three columns in the output sheet and 'stack' the data in these columns. One problem is that when I try to run it, it doesn't recognise my blank cells and stacks the entire column.

All help is welcome. You'll be my hero. Thank you very much in advance!

 

[lerrokrednas]

So, I guess I figured out the solution to my question myself. Too bad it requires a manual check of the numbers. However, it now runs light and clean.

Still, does anyone have a clue how to solve for the manual input?

Code I'm using after the fix:

Worksheets("Sheet1").Range("B6:AE131").Copy Destination:=Worksheets("Dates").Range("B1") '**CHECK NUMBERS**

Worksheets("Sheet1").Range("B132:AE257").Copy Destination:=Worksheets("StockPrices").Range("B1") '**CHECK NUMBERS**
Worksheets("Sheet1").Range("B258:AE383").Copy Destination:=Worksheets("MarketPrice").Range("B1") '**CHECK NUMBERS**


Worksheets("Dates").Activate
Dim i As Long 
Dim Lastrow As Long
Dim Lastrowa As Long
    For i = 2 To 33 '**CHECK NUMBER OF COLUMNS**
        Lastrow = Cells(Rows.Count, "A").End(xlUp).Row + 1
        Lastrowa = Cells(Rows.Count, i).End(xlUp).Row
        Range(Cells(1, i), Cells(Lastrowa, i)).Copy Cells(Lastrow, 1)
    Next
    
Worksheets("StockPrices").Activate
    For i = 2 To 33 '**CHECK NUMBERS OF COLUMNS**
        Lastrow = Cells(Rows.Count, "A").End(xlUp).Row + 1
        Lastrowa = Cells(Rows.Count, i).End(xlUp).Row
        Range(Cells(1, i), Cells(Lastrowa, i)).Copy Cells(Lastrow, 1)
    Next


Worksheets("MarketPrice").Activate
    For i = 2 To 33 '**CHECK NUMBERS OF COLUMNS**
        Lastrow = Cells(Rows.Count, "A").End(xlUp).Row + 1
        Lastrowa = Cells(Rows.Count, i).End(xlUp).Row
        Range(Cells(1, i), Cells(Lastrowa, i)).Copy Cells(Lastrow, 1)
    Next