VBA to Stack All Values on Sheet to One Column

[tradeaccepted]

I have an Excel sheet with 30K or so rows of data, all in the column A. Each cell in column A has multiple values that are separated by a semicolon.
I need to get all of these individual values into one column, preferably A.

My current solution is:

1. Text to Columns with semicolon as the delimiter.
2. VBA script to sort all columns in the sheet, one column at a time, A-Z.
   1. This is used because the following script does not skip blanks, therefore hitting the cell limit for a column.
3. VBA script to stack all columns into row A.
   1. This script is inefficient because I have to state each column that I want to stack into an Array.

Each of the formulas is pretty slow. I found this VBA script which is insanely fast but for some reason, it only copies the first column or two. http://nandeshwar.info/useful-procedures/stack-columns-of-data-on-one-column/


Could anyone provide a better way to complete this task? Also looking to not be limited to 30K rows, some sheets have a lot more than that.


VBA Script 1

Sub Sort750Columns()
    Dim x As Long, y As Long    
    On Error Resume Next
    
    For x = 1 To 750 'loop thru columns
        y = Cells(Rows.Count, x).End(xlUp).Row 'count rows in each column
        Range(Cells(3, x), Cells(y, x)).Sort Key1:=Cells(3, x), Order1:=xlAscending, Header:=xlYes
    Next x
    
End Sub

VBA Script 2

Sub multiple_columns_to_one()'
' multiple_columns_to_one Macro
'


' This will take all values from Columns B to BZ and stack them into column A.
    Dim K As Long, ar
    K = 1
    For Each ar In Array("B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "AA", "AB", "AC", "AD", "AE", "AF", "AG", "AH", "AI", "AJ", "AK", "AL", "AM", "AN", "AO", "AP", "AQ", "AR", "AS", "AT", "AU", "AV", "AW", "AX", "AY", "AZ", "BA", "BB", "BC", "BD", "BE", "BF", "BG", "BH", "BI", "BJ", "BK", "BL", "BM", "BN", "BO", "BP", "BQ", "BR", "BS", "BT", "BU", "BV", "BW", "BX", "BY", "BZ")
        For i = 1 To 10000
            If Cells(i, ar).Value <> "" Then
                Cells(K, "A").Value = Cells(i, ar).Value
                K = K + 1
            End If
        Next i
    Next ar
End Sub

 

[Yongle]

Hi
Trying to understand exactly what you want:

1. Must the data to be sorted before it is moved into columnA?
(quicker approach - move the data and sort once- would that provide acceptable result?)
2. Are there always 78 columns of data?
(quicker approach - process only actually used columns)
3. Why the inconsistency between your 2 scripts?
(script1 = 750 columns, script2 = 78 columns)
4. Is the first cell with data always A4? What is in A1,A2,A3?
(based on Range(Cells(3, x), Cells(y, x)).Sort)
5. Script1 run handles 10,000 rows , but you say there are 30,000 rows - better to use actual used rows
(For i = 1 To 10000, I have an Excel sheet with 30K or so rows of data)

 

[Yongle]

The code below runs in 5 seconds
- with 10,000 rows of data in columnA
- which becomes 80 columns (afterTextToColumns)
- which becomes 732,000 rows (after data moved to columnA)

Does it do what you require?
(note - it could be speeded up further if arrays used)

Assumes Header is in A4 and data is sorted once at the end

Test on a copy of your worksheet!

Sub Test()
    [COLOR=#ff0000]'run from sheet containing the data[/COLOR]
    Dim ws As Worksheet, colCount As Long, rowCount As Long, c As Long, rng As Range
    Set ws = ActiveSheet
    
    Application.ScreenUpdating = False
    Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote
    ThisWorkbook.Save                                       'workbook saved to update UsedRange
    Set rng = ws.UsedRange
    With rng
        colCount = .Columns(.Columns.Count).Column
        rowCount = .Rows(.Rows.Count).Row
            For c = 2 To colCount
                .Cells(4, c).Resize(rowCount).Copy ws.Cells(Rows.Count, 1).End(xlUp).Offset(1)
            Next
        .Offset(, 1).ClearContents
    End With
    ws.Cells(1).Resize(3).EntireRow.Delete
    ws.Range("A:A").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes
End Sub

 

[tradeaccepted]

Hi
Trying to understand exactly what you want:

1. Must the data to be sorted before it is moved into columnA?
(quicker approach - move the data and sort once- would that provide acceptable result?)

The only reason the data is sorted is that "VBA Script 2" does not skip blanks. If you run "VBA Script 2" and you have two columns both with one value at row 500,000 in column B and C, the script will error because of an overflow. It will input all the blanks from rows 1-499,999, which I don't want. I only want the values to be stacked in column A, skipping blanks.

2. Are there always 78 columns of data?
(quicker approach - process only actually used columns)

This number is never the same, the most I have ever seen was some 1100 columns, but this could increase or decrease.

3. Why the inconsistency between your 2 scripts?
(script1 = 750 columns, script2 = 78 columns)

Because with "VBA Script 1" it is easy to input a variable and have it sort the columns based on that. With "VBA Script 2" I would have to input all 750 of those column letters. I did not do this and came to the forum for guidance.

4. Is the first cell with data always A4? What is in A1,A2,A3?
(based on Range(Cells(3, x), Cells(y, x)).Sort)

The data is all in column A. There is a header, so data starts in A2 and extends to however many rows. Could be 5 or 500,000.

5. Script1 run handles 10,000 rows, but you say there are 30,000 rows - better to use actual used rows
(For i = 1 To 10000, I have an Excel sheet with 30K or so rows of data)

"VBA Script 2" does handle 10,000. I am looking for the script to be able to calculate where the last cell in the sheet is with data and perform the stacking. I don't want to have to ever change the script based on the size of the sheet.

Hope this clears things up and thanks for taking time to answer.

 

[Yongle]

Just spotted an error in post#3

TextToColumns line should be

ws.Range("A:A").TextToColumns Destination:=ws.Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, Semicolon:=True

 

[tradeaccepted]

Yongle,

Thanks so much for writing this up for me. When I run the script on the sample sheet that I added to my main post, the data does not come back as expected. The results still have semicolons in them and look to be duplicated. This might be because of the blank rows?

Please take a look at my responses to your original questions, and again I do appreciate you taking the time to look into this for me.

 

[tradeaccepted]

Just spotted an error in post#3

TextToColumns line should be

ws.Range("A:A").TextToColumns Destination:=ws.Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, Semicolon:=True

I think this working as intended!!! Will test some more and reply back if I find anything, you are a lifesaver.

 

[tradeaccepted]

Just spotted an error in post#3

TextToColumns line should be

ws.Range("A:A").TextToColumns Destination:=ws.Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, Semicolon:=True

Yongle,

Thank you again. One problem I am seeing is that it does not skip blank cells. Excel row limit is 1,048,576.

Let's say after the text is delimited, I have data in columns A and B. The data starts at row 525,000, so if I have only two columns and each column has data in cell 525,000. A525000 and B525000.

The script will paste the data into column A at row 525000 and then it will try the 2nd value at A1,050,000 which will throw an error. This is the reason that I was sorting all columns before stacking back into column A.


Could the script be updated to exclude blank cells, or to sort each column individually before stacking into column A? Whatever you think is that fastest/safest method.

 

[tradeaccepted]

Sorry for my ADD. I was able to combine the sort script from my first post with your code. I was able to use your range variable to find the last cells to grab. This does work but I am getting a "Cannot complete the task with the available resources" error.
The sheet has 29,000 rows of data, when delimited the furthest value stretches to column 650. The columns could potentially go into the thousands.

Running Excel 2007 32bit, 16GB RAM, i5. We are probably upgrading to 2013 by the end of the year, and it will still be 32 bit.

About 5m into writing this post, excel popped up another error which tells me its still trying to process in the background.
Any ideas how to make it more eloquent? I think finding a way to skip blanks woud be faster/better.

Sub Test()    'run from sheet containing the data
    Dim ws As Worksheet, colCount As Long, rowCount As Long, c As Long, rng As Range, x As Long, y As Long
    On Error Resume Next
    Set ws = ActiveSheet
    
    Application.ScreenUpdating = False
    ws.Range("A:A").TextToColumns Destination:=ws.Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, Semicolon:=True
    ThisWorkbook.Save                                       'workbook saved to update UsedRange
    Set rng = ws.UsedRange
    
       
    For x = 1 To rng 'loop thru columns
        y = Cells(Rows.Count, x).End(xlUp).Row 'count rows in each column
        Range(Cells(3, x), Cells(y, x)).Sort Key1:=Cells(3, x), Order1:=xlAscending, Header:=xlYes
    Next x
    


    
    With rng
        colCount = .Columns(.Columns.Count).Column
        rowCount = .Rows(.Rows.Count).Row
            For c = 2 To colCount
                .Cells(4, c).Resize(rowCount).Copy ws.Cells(Rows.Count, 1).End(xlUp).Offset(1)
            Next
        .Offset(, 1).ClearContents
    End With
    ws.Cells(1).Resize(3).EntireRow.Delete
    ws.Range("A:A").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes
End Sub

 

[Fluff]

How about

Sub SplitData()
   Dim Src As Variant
   Dim Ary() As Variant
   Dim Lr As Long, i As Long
   
   Lr = Range("A" & Rows.Count).End(xlUp).Row
   Src = Application.Transpose(Range("A1:A" & Lr))
   ReDim Ary(1 To Lr)
   For i = 1 To Lr
      Ary(i) = Split(Src(i), ";")
   Next i
'   Range("A:A").Clear
   For i = 1 To Lr
      Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(Ary(i)) + 1).Value = Application.Transpose(Ary(i))
   Next i
End Sub

This will currently put the values in col B as a test