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
05/07/1608/10/18...These are dates
06/07/1609/10/18...→ ±1000 observations
.........↓ ±200 observations




130.05250.30...These are stock prices
132.20251.34...→ ±1000 observations
.........↓ ±200 observations




2,088.202,109.03...These are market prices
2,090.542,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/16130.052,088.20
06/07/16132.202,090.54
.........
08/10/18200.302,109.03
09/10/18201.342,120.10
.........

<tbody>
</tbody>


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!
 

lerrokrednas

New Member
Joined
Dec 5, 2018
Messages
2
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

 

Forum statistics

Threads
1,082,323
Messages
5,364,579
Members
400,809
Latest member
formulasataglance

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top