Need A Macro that takes comma delimited values in select columns and seperates them to row

Hello Everyone,

New to the forum and looking for some help,

I have a large ecomm spreadsheet that comes from vendors with multiple item attributes in a single cell in a number of columns. I need the macro to go through select columns and seperate these comma delimited attributes to a newly inserted row below the original while keeping the first attribute in the original cell.

Attached is my current code in VB(be gentle, I was never taught VB), it works to an extent, however, it does not move past the first row. And if, say column B has 3 attributes in row 1, and 5 attributes in column D of row 1, the last 2 of column D are being chopped off. I need it to not cut these off and be OK with later columns have more inserted rows.

TroyMacro.txt

Any help on this would be great,

Thanks to everyone in advance.

I am not able to attach a legitimate smaple workbook, but I can attach a screenshot of what im seeingvs what I need. I hope that this will help.MACROexample.png

Thanks,

Please post your code directly to the forum in the post, using code tags. (It's easier than attaching a text file with the code that others have to download and open to read):
[CODE]Your code lines between tags[/CODE] results --->

your code lines

Option Explicit
Sub Split_BD()

    Dim ArrPtr      As Long, _
        RecCount    As Long, _
        MaxBD       As Long, _
        DestRow     As Long, _
        Split_B()   As String, _
        Split_D()   As String, _
        TestCell    As Variant, _
        DEST        As Worksheet, _
        SOURCE      As Worksheet

    Set SOURCE = Sheets("Sheet1")
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("Workspace").Delete
    On Error GoTo 0
    
    Sheets.Add after:=Sheets(Sheets.Count)
    ActiveSheet.Name = "WorkSpace"
    Set DEST = ActiveSheet
    Application.DisplayAlerts = True
    
    With Worksheets("Sheet1")
        RecCount = .Cells(.Rows.Count, "A").End(xlUp).Row

        For Each TestCell In .Range("A1:A" & RecCount)
            Split_B = Split(TestCell.Offset(columnoffset:=1).Value, ",")
            Split_D = Split(TestCell.Offset(columnoffset:=3).Value, ",")
            
            'get the larger upper bound of the two arrays
            MaxBD = WorksheetFunction.Max(UBound(Split_B), UBound(Split_D))
            
            'make both arrays same size
            'the previously smaller one will have a blank last element
            
            ReDim Preserve Split_B(0 To MaxBD)
            ReDim Preserve Split_D(0 To MaxBD)
            
            For ArrPtr = 0 To MaxBD
                DestRow = DestRow + 1
                
                'write column A & C once for each group
                If ArrPtr = 0 Then
                    DEST.Cells(DestRow, "A").Value = TestCell.Value
                    DEST.Cells(DestRow, "C").Value = TestCell.Offset(columnoffset:=2).Value
                End If
                
                'write all array elements
                DEST.Cells(DestRow, "B").Value = Split_B(ArrPtr)
                DEST.Cells(DestRow, "D").Value = Split_D(ArrPtr)
            Next ArrPtr
        Next TestCell
    End With
End Sub

Assume columns C & E shall not be split; B, D & F are split

Option Explicit
Sub Split_BDF()

    Dim ArrPtr      As Long, _
        RecCount    As Long, _
        MaxBD       As Long, _
        DestRow     As Long, _
        Split_B()   As String, _
        Split_D()   As String, _
        Split_F()   As String, _
        TestCell    As Variant, _
        DEST        As Worksheet, _
        SOURCE      As Worksheet

    Set SOURCE = Sheets("Sheet1")
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("Workspace").Delete
    On Error GoTo 0
    
    Sheets.Add after:=Sheets(Sheets.Count)
    ActiveSheet.Name = "WorkSpace"
    Set DEST = ActiveSheet
    Application.DisplayAlerts = True
    
    With SOURCE
        RecCount = .Cells(.Rows.Count, "A").End(xlUp).Row

        For Each TestCell In .Range("A1:A" & RecCount)
            'columns B, D & F shall be split
            Split_B = Split(TestCell.Offset(columnoffset:=1).Value, ",")
            Split_D = Split(TestCell.Offset(columnoffset:=3).Value, ",")
            Split_F = Split(TestCell.Offset(columnoffset:=5).Value, ",")
            
            'get the larger upper bound of the two arrays
            MaxBD = WorksheetFunction.Max(UBound(Split_B), UBound(Split_D), UBound(Split_F))
            
            'make both arrays same size
            'the previously smaller one will have a blank last element
            
            ReDim Preserve Split_B(0 To MaxBD)
            ReDim Preserve Split_D(0 To MaxBD)
            ReDim Preserve Split_F(0 To MaxBD)
            
            For ArrPtr = 0 To MaxBD
                DestRow = DestRow + 1
                
                'write column A, C & E once only for each group
                If ArrPtr = 0 Then
                    DEST.Cells(DestRow, "A").Value = TestCell.Value
                    DEST.Cells(DestRow, "C").Value = TestCell.Offset(columnoffset:=2).Value
                    DEST.Cells(DestRow, "E").Value = TestCell.Offset(columnoffset:=4).Value
                End If
                
                'write all array elements
                DEST.Cells(DestRow, "B").Value = Split_B(ArrPtr)
                DEST.Cells(DestRow, "D").Value = Split_D(ArrPtr)
                DEST.Cells(DestRow, "F").Value = Split_F(ArrPtr)
            Next ArrPtr
        Next TestCell
    End With     'SOURCE
End Sub