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]

@Fluff
- your code is much faster than mine getting to the same result. So it makes sense to modify yours to match OP requirements

What is the most efficient way to modify your code to remove blank values in the array BEFORE attributing the values to columnB ?

 

[tradeaccepted]

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

Fluff/Yongle,

Thanks for working on this! I ran the code and it brings over about 5000 of the values into column B and then gets a type mismatch error.
I apologize for not uploading a sample sheet, I know this would have been useful. Here is an example workbook of the data. I used a random generator to get fake email addresses.
https://www108.zippyshare.com/v/YbLghvBC/file.html

The AfterVBA sheet shows how the data should be displayed after the VBA is run.(Note it should not trim anything)
You will see many duplicates on the list, this is fine. The generator only lets me make 1000 unique lines, so please imagine that these are more unique values on the list than what you see.


Please let me know if I can explain anything further.

 

[Fluff]

Thanks for the file, but I will not download from that site, as there are too many download buttons.
Would you be able to place it on OneDrive, DropBox, or GoogleDrive?

 

[tradeaccepted]

Sorry about that, this host has no intrusive ads: https://nofile.io/f/7HQkxNCQyxS

 

[Fluff]

Ok try this

Sub SplitData()
   Dim Src As Variant
   Dim Ary() As Variant
   Dim Lr As Long, i As Long, j As Long
Application.ScreenUpdating = False
   Lr = Range("B" & Rows.Count).End(xlUp).Row
   Src = Range("B2:B" & Lr)
   ReDim Ary(1 To Lr)
   For i = 1 To Lr - 1
      If Not IsEmpty(Src(i, 1)) Then
         j = j + 1
         Ary(j) = Split(Src(i, 1), ";")
      End If
   Next i
'   Range("A:A").Clear
   For i = 1 To j
      Range("C" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(Ary(i)) + 1).Value = Application.Transpose(Ary(i))
   Next i
End Sub

But on your test data it's still likely to take some time

 

[tradeaccepted]

And there it is! The script worked and took about 45seconds. You are amazing, I appreciate it greatly!

 

[Fluff]

Glad we could help & thanks for the feedback