VBA code to filter and separate delimited refs to separate worksheets

[Sindrin]

In a worksheet, I have a list of unique references which are combined with a delimiter in Col.A

These references are with delimiter "|"

Example:

-Row 1 are headings.
-Row 2 have Cell A2 as ["ABC123 | DEF123 | GHI123"]
-Row 3 have Cell A3 as ["ABC123 | XYZ123 | LMN123 | DEF123 | JKL123"]
-Other rows follow the same format with various refs within the cell etc

Query:

I do have the list of unique refs (without the delimiter) on a separate sheet.

Is there a quick way I can split the worksheet [with the combined refs] based on the individual unique refs?

So output would be:

One worksheet will contain all rows containing unique ref "ABC123"
One worksheet will contain all rows containing unique ref "DEF123"
One worksheet will contain all rows containing unique ref "GHI123"
One worksheet will contain all rows containing unique ref "LMN123"
One worksheet will contain all rows containing unique ref "XYZ123"
One worksheet will contain all rows containing unique ref "JKL123"

It would be great if we can keep the headers on the output rows as well

Thank you in advance

 

[Sindrin]

I will rerun the code again tomorrow and test.

By the way, how easy is it to further enhance this code to :

Once it exported the rows containing abc123 in column A (from the delimited refs) to a new sheet called abc123.

Is it possible to amend col A of that row to just abc123?

 

[aRandomHelper]

Is it possible to amend col A of that row to just abc123?

Yes, that's possible. Also amended the code, it should improve the speed slightly; it now uses a variable to get the row number to fill in data instead of always moving from last cell of sheet up to the last used cell's row.

Sub me1158451()
    Dim s, i As Long, d, v, t, r As Long
    Set d = CreateObject("scripting.dictionary")
    Set ws = ActiveSheet
    With ws
        For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
            s = .Cells(i, 1).Value
            s = Replace(s, " | ", "|")
            s = Replace(Replace(s, "[""", ""), """]", "") 'remove this line if your data does not contain '["' and '"]'
            v = Split(s, "|")
            For Each t In v
                If d.exists(t) Then
                    d(t) = d(t) & "_" & i
                Else
                    d(t) = i
                End If
            Next
        Next
    End With
    For Each t In d.keys
        With Sheets.Add(, Sheets(Sheets.Count))
            .Name = t
            .Cells(1, 1).Resize(, 26).Value = ws.Cells(1, 1).Resize(, 26).Value
            v = Split(d(t), "_")
            r = 2
            For Each s In v
                .Cells(r, 1).Value = t
                .Cells(r, 2).Resize(, 25).Value = ws.Cells(CInt(s), 2).Resize(, 25).Value
                r = r + 1
            Next
        End With
    Next
End Sub

How did your testing go?

 

[Sindrin]

Yes, that's possible. Also amended the code, it should improve the speed slightly; it now uses a variable to get the row number to fill in data instead of always moving from last cell of sheet up to the last used cell's row.

Sub me1158451()
    Dim s, i As Long, d, v, t, r As Long
    Set d = CreateObject("scripting.dictionary")
    Set ws = ActiveSheet
    With ws
        For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
            s = .Cells(i, 1).Value
            s = Replace(s, " | ", "|")
            s = Replace(Replace(s, "[""", ""), """]", "") 'remove this line if your data does not contain '["' and '"]'
            v = Split(s, "|")
            For Each t In v
                If d.exists(t) Then
                    d(t) = d(t) & "_" & i
                Else
                    d(t) = i
                End If
            Next
        Next
    End With
    For Each t In d.keys
        With Sheets.Add(, Sheets(Sheets.Count))
            .Name = t
            .Cells(1, 1).Resize(, 26).Value = ws.Cells(1, 1).Resize(, 26).Value
            v = Split(d(t), "_")
            r = 2
            For Each s In v
                .Cells(r, 1).Value = t
                .Cells(r, 2).Resize(, 25).Value = ws.Cells(CInt(s), 2).Resize(, 25).Value
                r = r + 1
            Next
        End With
    Next
End Sub

How did your testing go?

Wow! Super fast now and the output is exactly as I wanted. Tested and verified.

Thank you for doing this !

When you get time can you break down the above vba and describe what each line is doing ?

This is just to enhance my understanding and hopefully I can tweak the code in the future for other files.

Many thanks,
Prinz

 

[aRandomHelper]

Wow! Super fast now and the output is exactly as I wanted. Tested and verified.

Glad it worked, you're welcome.

When you get time can you break down the above vba and describe what each line is doing ?

Sub me1158451()
    Dim s, i As Long, d, v, t, r As Long
    Set d = CreateObject("scripting.dictionary") 'think of dictionary as a more powerful version of array, with the ability to use Strings as 'index', unlike regular arrays which usually only use Integers.
    Set ws = ActiveSheet
    With ws
        For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row 'loops through your data
            s = .Cells(i, 1).Value
            s = Replace(s, " | ", "|") ' "trims" off space between the delimiters
            s = Replace(Replace(s, "[""", ""), """]", "") ' "trims" off '["' and '"]'
            v = Split(s, "|") ' split data (tokens) by the delimiter "|" and stores in array 'v'
            For Each t In v ' for each token in array (ABC123 / DEF123 / etc.)
                If d.exists(t) Then  ' has this token been stored in dict before?
                    d(t) = d(t) & "_" & i ' yes, store the row number containing this token with a delimiter " _ "
                Else
                    d(t) = i ' no, it's a new token, 'creates' this in dict, and storing the row number at the same time
                End If
            Next
        Next
    End With
    For Each t In d.keys ' for each token stored in dict
        With Sheets.Add(, Sheets(Sheets.Count))
            .Name = t ' set sheet name to token value
            .Cells(1, 1).Resize(, 26).Value = ws.Cells(1, 1).Resize(, 26).Value ' copies header row over to new sheet
            v = Split(d(t), "_") ' split the stored row numbers for this token and stores in array 'v'
            r = 2
            For Each s In v ' for each stored row number
                .Cells(r, 1).Value = t ' output the token to row r, column "A" of new sheet
                .Cells(r, 2).Resize(, 25).Value = ws.Cells(CInt(s), 2).Resize(, 25).Value ' copies columns "B:Z" of the stored row number to row r of new sheet
                r = r + 1
            Next
        End With
    Next
End Sub

 

[Sindrin]

Glad it worked, you're welcome.

Sub me1158451()
    Dim s, i As Long, d, v, t, r As Long
    Set d = CreateObject("scripting.dictionary") 'think of dictionary as a more powerful version of array, with the ability to use Strings as 'index', unlike regular arrays which usually only use Integers.
    Set ws = ActiveSheet
    With ws
        For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row 'loops through your data
            s = .Cells(i, 1).Value
            s = Replace(s, " | ", "|") ' "trims" off space between the delimiters
            s = Replace(Replace(s, "[""", ""), """]", "") ' "trims" off '["' and '"]'
            v = Split(s, "|") ' split data (tokens) by the delimiter "|" and stores in array 'v'
            For Each t In v ' for each token in array (ABC123 / DEF123 / etc.)
                If d.exists(t) Then  ' has this token been stored in dict before?
                    d(t) = d(t) & "_" & i ' yes, store the row number containing this token with a delimiter " _ "
                Else
                    d(t) = i ' no, it's a new token, 'creates' this in dict, and storing the row number at the same time
                End If
            Next
        Next
    End With
    For Each t In d.keys ' for each token stored in dict
        With Sheets.Add(, Sheets(Sheets.Count))
            .Name = t ' set sheet name to token value
            .Cells(1, 1).Resize(, 26).Value = ws.Cells(1, 1).Resize(, 26).Value ' copies header row over to new sheet
            v = Split(d(t), "_") ' split the stored row numbers for this token and stores in array 'v'
            r = 2
            For Each s In v ' for each stored row number
                .Cells(r, 1).Value = t ' output the token to row r, column "A" of new sheet
                .Cells(r, 2).Resize(, 25).Value = ws.Cells(CInt(s), 2).Resize(, 25).Value ' copies columns "B:Z" of the stored row number to row r of new sheet
                r = r + 1
            Next
        End With
    Next
End Sub

Trying to run this on a file with 80k rows - no error but nothing happens.

When I hit escape it points to "End If" statement.

I waited for 15mins plus but nothing happens when I don't escape the code.

Any reason why it isn't working?

Many thanks!

 

[aRandomHelper]

When I hit escape it points to "End If" statement.

This is a sign the code is at least still running fine, except it's taking some time because of the amount of data.

I waited for 15mins plus but nothing happens when I don't escape the code.

Any reason why it isn't working?

If possible, let it run for an hour or so. It is still plausible for the code to take more than 15mins for over 80k rows -- this speed also depends largely on the computer that you're running the code on.
The only reason I can think of right now that would result in nothing happening is if you run it on an empty active sheet, or if your data structure (columns) had some changes, but that shouldn't be the case.

 

[Sindrin]

Will try and leave it for hour and check

Just to be specific (to maybe adjust the VBA code if it can be)

There are 195 column headers
There are 92,356 rows

More accurate depiction of Column A with the delimited refs:

Row 2: E_A_N_A2-99 | E_A_N_T2-09 | E_A_N_QC1-51 | E_A_N_CV1-62
Row 3: E_A_N_A2-99 | E_A_N_T2-09
Row 4: E_A_N_QC1-51 | E_A_N_CV1-62
Row 5: E_A_N_QC1-51
Row 6: E_A_N_T2-09 | E_A_N_QC1-51

And so on...

So for this (row 2-6 data) as an example

VBA Output would be:

4 new sheets
1. Sheet "E_A_N_A2-99": The sheet will include the 195 column headers + all the the row data which contains this delimited ref
2. Sheet "E_A_N_T2-09": The sheet will include the 195 column headers + all the the row data which contains this delimited ref
3. Sheet "E_A_N_QC1-51": The sheet will include the 195 column headers + all the the row data which contains this delimited ref
4. Sheet "E_A_N_CV1-62": The sheet will include the 195 column headers + all the the row data which contains this delimited ref

This is a sign the code is at least still running fine, except it's taking some time because of the amount of data.


If possible, let it run for an hour or so. It is still plausible for the code to take more than 15mins for over 80k rows -- this speed also depends largely on the computer that you're running the code on.
The only reason I can think of right now that would result in nothing happening is if you run it on an empty active sheet, or if your data structure (columns) had some changes, but that shouldn't be the case.

 

[aRandomHelper]

Given your examples, I think it shouldn't make the code break, just the sheer amount of rows slowing it down.

Another thing you can try to "check" progress is, when you press Esc and the code pauses, mouse over the variable i and see what number it's storing -- that would be the current row number being processed.

        For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row 'loops through your data
            ^

Any updates after leaving it for an hour or so?

 

[Sindrin]

Given your examples, I think it shouldn't make the code break, just the sheer amount of rows slowing it down.

Another thing you can try to "check" progress is, when you press Esc and the code pauses, mouse over the variable i and see what number it's storing -- that would be the current row number being processed.

        For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row 'loops through your data
            ^

Any updates after leaving it for an hour or so?

It was still processing after an hour so I just split the data to small chunks and ran the macro which worked.

Also can I ask I noticed when the splits are happening (e.g. new additional sheets are added with the relevant data) I noticed some of the values are being truncated i.e. 1438439480348930 to 1.01000028020201E+41. Can this be fixed?

Thank you!

 

[aRandomHelper]

I noticed some of the values are being truncated i.e. 1438439480348930 to 1.01000028020201E+41. Can this be fixed?

Maybe you can try setting the numberformats first:

                .Cells(r, 2).Resize(, 25).NumberFormat = ws.Cells(CInt(s), 2).Resize(, 25).NumberFormat 'add this line
                .Cells(r, 2).Resize(, 25).Value = ws.Cells(CInt(s), 2).Resize(, 25).Value ' copies columns "B:Z" of the stored row number to row r of new sheet

If it still doesn't work, another way I can think of to fix this, is to really use the copy function.

Change this

.Cells(r, 2).Resize(, 25).Value = ws.Cells(CInt(s), 2).Resize(, 25).Value ' copies columns "B:Z" of the stored row number to row r of new sheet

To this

ws.Cells(CInt(s), 2).Resize(, 25).Copy .Cells(r, 2).Resize(, 25) ' copies columns "B:Z" of the stored row number to row r of new sheet

But I believe it would slow down your code further.