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

lerrokrednas

New Member
Joined
Dec 5, 2018
Messages
2
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
[TABLE="class: grid, width: 400, align: left"]
<tbody>[TR]
[TD]05/07/16[/TD]
[TD]08/10/18[/TD]
[TD]...[/TD]
[TD]These are dates[/TD]
[/TR]
[TR]
[TD]06/07/16[/TD]
[TD]09/10/18[/TD]
[TD]...[/TD]
[TD]→ ±1000 observations[/TD]
[/TR]
[TR]
[TD]...[/TD]
[TD]...[/TD]
[TD]...[/TD]
[TD]↓ ±200 observations[/TD]
[/TR]
[TR]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]130.05[/TD]
[TD]250.30[/TD]
[TD]...[/TD]
[TD]These are stock prices[/TD]
[/TR]
[TR]
[TD]132.20[/TD]
[TD]251.34[/TD]
[TD]...[/TD]
[TD]→ ±1000 observations[/TD]
[/TR]
[TR]
[TD]...[/TD]
[TD]...[/TD]
[TD]...[/TD]
[TD]↓ ±200 observations[/TD]
[/TR]
[TR]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]2,088.20[/TD]
[TD]2,109.03[/TD]
[TD]...[/TD]
[TD]These are market prices[/TD]
[/TR]
[TR]
[TD]2,090.54[/TD]
[TD]2,120.10[/TD]
[TD]...[/TD]
[TD]→ ±1000 observations[/TD]
[/TR]
[TR]
[TD]...[/TD]
[TD]...[/TD]
[TD]...[/TD]
[TD]↓ ±200 observations[/TD]
[/TR]
</tbody>[/TABLE]



















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

[TABLE="class: grid, width: 400"]
<tbody>[TR]
[TD]05/07/16[/TD]
[TD]130.05[/TD]
[TD]2,088.20[/TD]
[/TR]
[TR]
[TD]06/07/16[/TD]
[TD]132.20[/TD]
[TD]2,090.54[/TD]
[/TR]
[TR]
[TD]...[/TD]
[TD]...[/TD]
[TD]...[/TD]
[/TR]
[TR]
[TD]08/10/18[/TD]
[TD]200.30[/TD]
[TD]2,109.03[/TD]
[/TR]
[TR]
[TD]09/10/18[/TD]
[TD]201.34[/TD]
[TD]2,120.10[/TD]
[/TR]
[TR]
[TD]...[/TD]
[TD]...[/TD]
[TD]...[/TD]
[/TR]
</tbody>[/TABLE]


The code I'm currently using is the following:

Rich (BB code):
<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!
 

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
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:


Rich (BB code):
Worksheets("Sheet1").Range("B6:AE131").Copy Destination:=Worksheets("Dates").Range("B1") '**CHECK NUMBERS**
Rich (BB code):
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

 
Upvote 0

Forum statistics

Threads
1,223,901
Messages
6,175,277
Members
452,629
Latest member
SahilPolekar

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top