VBA Macro to split data

[Shwapx]

Hello All,

I'm trying to create a macro which splits data out of textjoin formula and output it as list.

I have created a macro which do that, but it's not moving the cells and the data is not correct. So I need to adjust the macro to add empty cell in column G to keep up with the data.

Here is my macro at the moment:

Sub SeparateDataForEachCell()
Dim lastRow As Long
Dim dataRange As Range
Dim cell As Range
Dim dataString As String
Dim dataArray() As String
Dim outputRange As Range
Dim outputCell As Range
Dim i As Integer

lastRow = Cells(Rows.Count, "I").End(xlUp).Row
Set dataRange = Range("I1:I" & lastRow)

For Each cell In dataRange
dataString = cell.Value

dataArray = Split(dataString, " / ")

Set outputCell = cell.Offset(0, -1)

For i = LBound(dataArray) To UBound(dataArray)
outputCell.Value = dataArray(i)
Set outputCell = outputCell.Offset(1)
Next i
Next cell
End Sub

Here is an example table:

Book1
	G	H	I
1	Test	ABC	ABC
2	Test23	ABC	ABC / ABV / AB23
3	Test24	ABB	ABB / AVV / AWW
4	Test25	ACC	ACC / ATT / AWQ / AUU
5		ATT
6		AWQ
7		AUU
8	Up you can see the output which I'm getting now
9	Below is the ouput which I'm looking for
10	Test	ABC
11	Test23	ABC
12		ABV
13		AB23
14	Test24	ABB
15		AVV
16		AWW
17	Test25	ACC
18		ATT
19		AWQ
20		AUU
Sheet1

 

[Rick Rothstein]

Ahh, now I think I see what you are trying to accomplish. Give this formula a try (keyed to the data you showed in Message #8)...

=TEXTSPLIT(TEXTJOIN("/",,SUBSTITUTE(G10:G14&"-"&H10:H14&"-"&I10:I14," / ","/--")),"-","/")

 

[Shwapx]

Ahh, now I think I see what you are trying to accomplish. Give this formula a try (keyed to the data you showed in Message #8)...

=TEXTSPLIT(TEXTJOIN("/",,SUBSTITUTE(G10:G14&"-"&H10:H14&"-"&I10:I14," / ","/--")),"-","/")

I think i'm almost there I need to add one more link to the cells and this is how it's looking.

=TEXTSPLIT(TEXTJOIN("/",,SUBSTITUTE(J2:J1000&"-"&K2:K1000&"-"&L2:L1000&"-"&M2:M1000," / ","/---")),"-","/")

But I'm getting SPILL error I'm trying to output this in column F,G,H and I where there are no formulas.

 

[Shwapx]

I think Im getting that because in column J I have numbers like 102-412-21 and so on and it's outputting way different format. Maybe because of the dash in the numbers?

Edit: Yes this was the reason I just replaced the dash with + and it's working now. Thank you!

 

[Shwapx]

Just one note how I can modify this to hide 0 in column G if there is no data in J,K,L,M.

 

[Rick Rothstein]

Just one note how I can modify this to hide 0 in column G if there is no data in J,K,L,M.

See if this fixes the problem...

=TEXTSPLIT(SUBSTITUTE(TEXTJOIN("/",,SUBSTITUTE(J2:J1000&"-"&K2:K1000&"-"&L2:L1000&"-"&M2:M1000," / ","/---")),"/---/","/"),"-","/")

 

[Shwapx]

See if this fixes the problem...

=TEXTSPLIT(SUBSTITUTE(TEXTJOIN("/",,SUBSTITUTE(J2:J1000&"-"&K2:K1000&"-"&L2:L1000&"-"&M2:M1000," / ","/---")),"/---/","/"),"-","/")

No it's not hiding the zeros.

See in the screenshot below.

Maybe with IF condition or IFERROR?

 

[Rick Rothstein]

Any chance you can post a file demonstrating this to DropBox (it's free and safe) so I can see exactly what your setup is. I tried to duplicate what I thought you had and the formula I posted worked fine for my guess at your layout, but your reply indicates I guessed wrong at how your data is arranged.

 

[Shwapx]

Ahh, now I think I see what you are trying to accomplish. Give this formula a try (keyed to the data you showed in Message #8)...2

=TEXTSPLIT(TEXTJOIN("/",,SUBSTITUTE(G10:G14&"-"&H10:H14&"-"&I10:I14," / ","/--")),"-","/")

Hello, Sorry for reopening this, but is there a way to modify the formula to fill out in the empty rows which are added the respective code as well for example test23 to be added in the empty row for each code ABC, ABV and AB23? So to look like this:

test.xlsm
	N	O
18	Test	ABC
19	Test23	ABC
20	Test23	ABV
21	Test23	AB23
22	Test24	ABB
23	Test24	AVV
24	Test24	AWW
25	Test25	ACC
26	Test25	ATT
27	Test25	AWQ
28	Test25	AUU
Sheet1

 

[Shwapx]

More or less like that with the 3 fields:

test.xlsm
	G	H	I
33	Test	Test1	ABC
34	Test23	Test2	ABC
35	Test23	Test2	ABV
36	Test23	Test2	AB23
37	Test24	Test3	ABB
38	Test24	Test3	AVV
39	Test24	Test3	AWW
40	Test25	Test4	ACC
41	Test25	Test4	ATT
42	Test25	Test4	AWQ
43	Test25	Test4	AUU
Sheet1

 

[Shwapx]

I think I was able to do it via macro:

Sub SplitAndCopyDataWithCorrectedHeader()
Dim ws As Worksheet
Dim lastRow As Long, destRow As Long
Dim i As Long, j As Long, k As Long
Dim headerRange As Range, header1Range As Range, header2Range As Range, header3Range As Range
Dim headerValue As String, header1Value As String, header2Value As String, header3Value As String
Dim valuesHeader As Variant, valuesHeader1 As Variant, valuesHeader2 As Variant, valuesHeader3 As Variant

' Set the worksheet where the data is located
Set ws = ThisWorkbook.Sheets("Sheet2")

' Find the last row with data in column G
lastRow = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row

' Set the ranges for Header, Header1, Header2, and Header3
Set headerRange = ws.Range("F11:F" & lastRow)
Set header1Range = ws.Range("G11:G" & lastRow)
Set header2Range = ws.Range("H11:H" & lastRow)
Set header3Range = ws.Range("I11:I" & lastRow)

' Initialize the destination row
destRow = lastRow + 1

' Loop through each row in the range
For i = 1 To header3Range.Rows.Count
headerValue = headerRange.Cells(i, 1).Value
header1Value = header1Range.Cells(i, 1).Value
header2Value = header2Range.Cells(i, 1).Value
header3Value = header3Range.Cells(i, 1).Value

' Split values in Header3 based on "/"
valuesHeader3 = Split(header3Value, " / ")

' Copy Header, Header1, Header2, and each split value in Header3
For j = LBound(valuesHeader3) To UBound(valuesHeader3)
' Find the last used column in the destination row
k = ws.Cells(destRow, ws.Columns.Count).End(xlToLeft).Column

' Increment the column index
k = k + 1

' Write values to the destination cells
ws.Cells(destRow, k).Value = headerValue ' Header value from cell F10
ws.Cells(destRow, k + 1).Value = header1Value
ws.Cells(destRow, k + 2).Value = header2Value
ws.Cells(destRow, k + 3).Value = valuesHeader3(j)

' Move to the next destination row
destRow = destRow + 1
Next j
Next i
End Sub