Transform Comma and Space Separated Values into a single row via VBA Code

[ceclay]

Hello,

I would like to seek help to have a VBA code wherein column I and J has (numbers) data separated by space or column. I want to put every data into separate row like below. If there are 3 numbers separated by space or comma in a cell in Column I then column J has also 3 numbers separated by either comma or space.

Data:

ANC.xlsm
	H	I	J	K	L
2	Milk	175644	89	cnn	Not Similar
3	Honey	54673547	89	bbc	Not Similar
4	Honey	456546 34634643 343543	100 89 100	bbc	Similar
5	MIlk	124124, 435453	33 12	bbc	Not Similar
6	Butter	3542354	120	bbc	Not Similar
7	MIlk	5463, 728282 4773	33 12, 55	bbc	Not Similar
Data

Result

ANC.xlsm
	O	P	Q	R	S
2	Milk	175644	89	cnn	Not Similar
3	Honey	54673547	89	bbc	Not Similar
4	Honey	456546	100	bbc	Similar
5	Honey	34634643	89	bbc	Similar
6	Honey	343543	100	bbc	Similar
7	MIlk	124124	33	bbc	Not Similar
8	MIlk	435453	12	bbc	Not Similar
9	Butter	3542354	120	bbc	Not Similar
10	MIlk	5463	33	bbc	Not Similar
11	MIlk	728282	12	bbc	Not Similar
12	MIlk	4773	55	bbc	Not Similar
Data

Thank you in advance.

 

[smozgur]

This might look confusing at first look but it is not actually, and of course, there are many other ways to do this in VBA.
I tried to comment as much as possible (most of the code consists of comments actually), but let me know if you have any questions.

Sub doIt()
Dim rng As Range
Dim trg As Range
Dim rw As Range
Dim cll1 As Range
Dim cll2 As Range
Dim items1 As Variant
Dim items2 As Variant
Dim i As Integer

    Set rng = Range("$H$2:$L$7")        'Source range: Based on the sample data - change as necessary
    Set trg = rng.Offset(, 7).Resize(1) 'Target range: Relative to sample data - change as necessary
   
    ' Loop through the rows in the selection
    For Each rw In rng.Rows
        ' Copy the current row to the target range
        ' we will do this for each rows in the source range
        rw.Copy trg
       
        ' We will work with the second column cell to see
        ' if it contains multiple values delimited with comma and/or space
        Set cll1 = trg.Cells(, 2)
        ' Replacing commas with spaces, if any
        ' to deal with single delimiter, space only
        cll1.Value = Replace(cll1.Value, ",", " ")
       
        ' Check if the cell contains any space
        If InStr(cll1, " ") Then
            ' This might look tricky,
            ' but this is how I would remove adjacent spaces
            ' if comma and space are used together
            ' by using the Excel TRIM function
            ' Note: VBA Trim function doesn't work the same way
            cll1.Formula = "=TRIM(""" & cll1.Value & """)"
           
            ' Store the multiple items in the array
            items1 = Split(cll1.Value, " ")
           
            ' We also need to split the third column cell
            ' Same this what we did for the second column cell above
            Set cll2 = trg.Cells(, 3)
            cll2.Value = Replace(cll2.Value, ",", " ")
            cll2.Formula = "=TRIM(""" & cll2.Value & """)"
            items2 = Split(cll2.Value, " ")
           
            ' Create a new row for each item in the second column cell
            ' Note that we are starting from the second row
            ' to be able to use the original row for the next item
            For i = 1 To UBound(items1)
                ' Copy the original row
                trg.Copy trg.Offset(i)
                ' Change the second column value with the
                ' next item in the deliited value
                trg.Offset(i).Cells(, 2).Value = items1(i)
                ' Do the same thing for the third column cell
                ' but consider it might contain less number of items
                ' because I don't know if this is a possible situation or not
                If UBound(items2) >= i Then
                    trg.Offset(i).Cells(, 3).Value = items2(i)
                Else
                    trg.Offset(i).Cells(, 3).Value = ""
                End If
            Next i
           
            ' Finally change the originally copied row
            ' by using the first items in the corresponding arrays
            trg.Cells(, 2).Value = items1(0)
            trg.Cells(, 3).Value = items2(0)
           
            Set trg = trg.Offset(UBound(items1) + 1)
        Else
            ' There is no space in the cell, continue with the next row
            Set trg = trg.Offset(1)
        End If
    Next rw
End Sub

 

[ceclay]

Hello @smozgur
Im getting issue below when I tried to run the macro.
Some notes:
1. Number of spaces or commas on column on I and J are random. (though cells I and J should have same number per row)
2. Range is also random, ie, number of rows are random. Can be upto 1000 rows or more.

ANC.xlsm
	O	P	Q	R	S
2	Milk	175644	89	cnn	Not Similar
3	Honey	54673547	89	bbc	Not Similar
4	Honey	=TRIM("456546	=TRIM()100	bbc	Similar
5	Honey	34634643	89	bbc	Similar
6	Honey	343543")	100()	bbc	Similar
7	MIlk	=TRIM("124124	=TRIM()33	bbc	Not Similar
8	MIlk		12()	bbc	Not Similar
9	MIlk	435453")		bbc	Not Similar
10	Butter	3542354	120	bbc	Not Similar
11	MIlk	=TRIM("5463	=TRIM()33	bbc	Not Similar
12	MIlk		12	bbc	Not Similar
13	MIlk	728282		bbc	Not Similar
14	MIlk	4773")	55()	bbc	Not Similar
Data

Cheers!

 

[smozgur]

It might be a data import issue, so your worksheet (or target range) doesn't evaluate formulas but stores them as text.

In the following sample, I used the Evaluate method. It should solve the problem.

#1 and #2 are already considered in the code. In fact, for #2, I applied an extra check to avoid macro to stop or halt. If both cells have the same number of delimited items all the time, then it won't change anything at all.

Please see the comments in the code for more information after you get the correct result with this revised code (only 3 lines changed, but I wanted to post the entire code to avoid confusion). Then let me know if you have any questions.

Sub doIt()
Dim rng As Range
Dim trg As Range
Dim rw As Range
Dim cll1 As Range
Dim cll2 As Range
Dim items1 As Variant
Dim items2 As Variant
Dim i As Integer

    Set rng = Range("$H$2:$L$7")        'Source range: Based on the sample data - change as necessary
    Set trg = rng.Offset(, 7).Resize(1) 'Target range: Relative to sample data - change as necessary
   
    ' Loop through the rows in the selection
    For Each rw In rng.Rows
        ' Copy the current row to the target range
        ' we will do this for each rows in the source range
        rw.Copy trg
       
        ' We will work with the second column cell to see
        ' if it contains multiple values delimited with comma and/or space
        Set cll1 = trg.Cells(, 2)
        ' Replacing commas with spaces, if any
        ' to deal with single delimiter, space only
        cll1.Value = Replace(cll1.Value, ",", " ")
       
        ' Check if the cell contains any space
        If InStr(cll1, " ") Then
            ' This might look tricky,
            ' but this is how I would remove adjacent spaces
            ' if comma and space are used together
            ' by using the Excel TRIM function
            ' Note: VBA Trim function doesn't work the same way
            ' Changed to use Evaluate function instead in-cell modification
            
           
            ' Store the multiple items in the array
            items1 = Split(Evaluate("=TRIM(""" & cll1.Value & """)"), " ")
           
            ' We also need to split the third column cell
            ' Same this what we did for the second column cell above
            Set cll2 = trg.Cells(, 3)
            cll2.Value = Replace(cll2.Value, ",", " ")
            items2 = Split(Evaluate("=TRIM(""" & cll2.Value & """)"), " ")
           
            ' Create a new row for each item in the second column cell
            ' Note that we are starting from the second row
            ' to be able to use the original row for the next item
            For i = 1 To UBound(items1)
                ' Copy the original row
                trg.Copy trg.Offset(i)
                ' Change the second column value with the
                ' next item in the deliited value
                trg.Offset(i).Cells(, 2).Value = items1(i)
                ' Do the same thing for the third column cell
                ' but consider it might contain less number of items
                ' because I don't know if this is a possible situation or not
                If UBound(items2) >= i Then
                    trg.Offset(i).Cells(, 3).Value = items2(i)
                Else
                    trg.Offset(i).Cells(, 3).Value = ""
                End If
            Next i
           
            ' Finally change the originally copied row
            ' by using the first items in the corresponding arrays
            trg.Cells(, 2).Value = items1(0)
            trg.Cells(, 3).Value = items2(0)
           
            Set trg = trg.Offset(UBound(items1) + 1)
        Else
            ' There is no space in the cell, continue with the next row
            Set trg = trg.Offset(1)
        End If
    Next rw
End Sub

 

[ceclay]

Thank you very much @smozgur for your help.

 

[ceclay]

Hello,
My next problem is when the format from the source is different. On the picture below, the blue one (598315 34897406) became a telephone number and when performing the code above it looks like the space was being neglected.

Below is the result when I run the code if there was a telephone number format.

 

[smozgur]

@ceclay - Could you please post a new mini-sheet (XL2BB) with the sample data causing your next problem, so I can test it and try to help?