VBA Seperate Comma Delimited String to Rows while keeping other data

[decadence]

Hi, I am trying to separate comma delimited cells into rows while keeping the data adjacent to it the same, however I have a non static range where the columns might be in a different place so I can't use the standard range up on specific columns.
Basically I am using a header and setting that column as the range, then I want to step through the cells and split out the cells into rows, and change the quantity to match the split out cells, see below for Example. Can someone help with this please

From This

MtlSeq	Revision	MfgComment	PurComment	QtyPer
10	D	R151,R69_1,R177	Generic	3
20	D	R188	Electrical	1
30	D	R1, R3	Generic	2

To This

MtlSeq	Revision	MfgComment	PurComment	QtyPer
10	D	R151	Generic	1
10	D	R69_1	Generic	1
10	D	R177	Generic	1
20	D	R188	Electrical	1
30	D	R1	Generic	1
30	D	R3	Generic	1

What I have so far is this......

Option Explicit
Dim Rng As Range, Fnd As Range, xVal As Range, vSplit

Sub SplitRef()
'Split References
    Set Rng = RngMfg
    For Each xVal in Rng
        vSplit = Split(xVal, ",")
        ''''''''''''''''''''''''''''''''''''''''''''''''Split into Rows
    Next xVal

End Sub

Function RngMfg() As Range
    Set Fnd = ActiveSheet.Columns.Find(what:="MfgComment", LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
        If Not Fnd Is Nothing Then
            Set RngMfg = Range(Fnd.Offset(1), Cells(Rows.Count, Fnd.Column).End(xlUp))
        End If
End Function

 

[MoshiM]

Try this.

Sub Split_Stuff()

Dim WS_D() As Variant, Split_CLCTN As New Collection, V As Long, W As Long, MtlSeq As Long, Revision As Long, _
MfgComment As Long, PurComment As Long, QtyPer, Temp_A() As String, Output_Array() As Variant, Temp_B() As Variant

WS_D = ActiveSheet.UsedRange.Value

With WorksheetFunction                          'load locations of headers to variables

    Temp_B = .Index(WS_D, 1, 0)'load headers

    MtlSeq = .Match("MtlSeq", Temp_B, 0)
    Revision = .Match("Revision", Temp_B, 0)
    MfgComment = .Match("MfgComment", Temp_B, 0)
    PurComment = .Match("PurComment", Temp_B, 0)
    QtyPer = .Match("QtyPer", Temp_B, 0)
End With

For V = 2 To UBound(WS_D, 1) 'loop rows skip headers

    Temp_A = Split(WS_D(V, MfgComment), ",")    'split the column MfgComment with a comma if one is present
   
    For W = LBound(Temp_A) To UBound(Temp_A)    'loop the array created and add a new array to collection
   
        Split_CLCTN.Add Array(WS_D(V, MtlSeq), WS_D(V, Revision), Temp_A(W), WS_D(V, PurComment), 1)
       
    Next W
   
Next V

Temp_B = Array(MtlSeq, Revision, MfgComment, PurComment, QtyPer) 'Store header locations in array

With Split_CLCTN

    ReDim Output_Array(1 To .Count, 1 To UBound(WS_D, 2))
   
    For V = 1 To .Count 'loop items in collection
   
        WS_D = .ITEM(V)
       
        For W = LBound(Temp_B) To UBound(Temp_B) 'place in array depending on header location
            Output_Array(V, Temp_B(W)) = WS_D(W)
        Next W
       
    Next V
   
End With

With ActiveSheet.UsedRange 'apply certain columns of array to worksheet starting at second row of worksheet

    For W = LBound(Temp_B) To UBound(Temp_B)
        With .Cells(2, Temp_B(W)).Resize(UBound(Output_Array, 1), 1)
            .Value2 = WorksheetFunction.Index(Output_Array, 0, Temp_B(W))
        End With
    Next W

End With

End Sub

 

[MoshiM]

Add

.Columns(Temp_B(W)).Offset(1, 0).ClearContents

on the next line after

For W = LBound(Temp_B) To UBound(Temp_B)

at the end to ensure there won't be any unwanted data.

 

[decadence]

Hi MoshiM, Im getting a type13 error on

Temp_B = .Index(WS_D, 1, 0)'load headers

 

[MoshiM]

Is your ActiveSheet the worksheet you want the macro to run on ?

 

[MoshiM]

Added some things to avoid certain errors.

The only thing that comes to mind for why you would get an error there is if you were on a newly created sheet either without any data on it or just a single cell.

Sub Split_Stuff()

Dim WS_D() As Variant, Split_CLCTN As New Collection, V As Long, W As Long, MtlSeq As Long, Revision As Long, Z As Long, _
MfgComment As Long, PurComment As Long, QtyPer, Temp_A() As String, Output_Array() As Variant, Temp_B() As Variant, _
Target_Sheet As Worksheet, RR As Range

Set Target_Sheet = ActiveSheet 'Change if you want to

Set RR = Target_Sheet.UsedRange

With RR

    If .Columns.Count < 5 Then
   
        MsgBox "Not enough columns on worksheet: " & Target_Sheet.Name
        Exit Sub
   
    Else
        WS_D= . Value
    End If

End With

Temp_A = Split("MtlSeq,Revision,MfgCommen,PurComment,QtyPer", ",")

With WorksheetFunction
   
    Do                                      'Find the first row that one of the above headers appears in
   
        If W = UBound(WS_D, 1) And Z = UBound(WS_D, 2) Then GoTo Columns_Not_Found
       
        Z = Z + 1
        If Z Mod UBound(WS_D, 2) = 1 Then
            W = W + 1
            Z = 1
        End If
       
    Loop Until Not IsError(Application.Match(WS_D(W, Z), Temp_A, 0))
   
    Temp_B = .Index(WS_D, W, 0)        'Make an array from that row.
   
    On Error GoTo Columns_Not_Found
   
    MtlSeq = .Match("MtlSeq", Temp_B, 0)
    Revision = .Match("Revision", Temp_B, 0)
    MfgComment = .Match("MfgComment", Temp_B, 0)
    PurComment = .Match("PurComment", Temp_B, 0)
    QtyPer = .Match("QtyPer", Temp_B, 0)
   
    Z = W + 1 'First non header row
   
End With

On Error GoTo 0

For V = Z To UBound(WS_D, 1) 'loop rows skip headers
 
    If Not IsEmpty(WS_D(V, MfgComment)) Then
   
        Temp_A = Split(WS_D(V, MfgComment), ",")    'Split the column MfgComment with a comma if one is present
 
        For W = LBound(Temp_A) To UBound(Temp_A)    'Loop the array created and add a new array to collection for each element
           
            Split_CLCTN.Add Array(WS_D(V, MtlSeq), WS_D(V, Revision), Temp_A(W), WS_D(V, PurComment), 1)
         
        Next W
   
    End If
   
Next V

Temp_B = Array(MtlSeq, Revision, MfgComment, PurComment, QtyPer) 'Store header locations in array

With Split_CLCTN

    ReDim Output_Array(1 To .Count, 1 To UBound(WS_D, 2))
 
    For V = 1 To .Count 'loop items in collection
 
        WS_D = .Item(V)
     
        For W = LBound(Temp_B) To UBound(Temp_B) 'place in array depending on header location
            Output_Array(V, Temp_B(W)) = WS_D(W)
        Next W
     
    Next V
 
End With

Application.ScreenUpdating = False

With RR 'apply certain columns of array to worksheet starting at second row of worksheet

    For W = LBound(Temp_B) To UBound(Temp_B)
   
        .Columns(Temp_B(W)).Offset(Z, 0).ClearContents
       
        With .Cells(Z, Temp_B(W)).Resize(UBound(Output_Array, 1), 1)
       
            .Value2 = WorksheetFunction.Index(Output_Array, 0, Temp_B(W))
           
        End With
       
    Next W

End With

Application.ScreenUpdating = True

Exit Sub

Columns_Not_Found:
    MsgBox "One or more necessary headers weren't found on worksheet: " & Target_Sheet.Name
   
End Sub

 

[MoshiM]

Miscellaneous changes for efficiency.

Sub Split_Stuff()

Dim WS_D() As Variant, Split_CLCTN As New Collection, V As Long, W As Long, MtlSeq As Long, Revision As Long, Data_Start As Long, _
MfgComment As Long, PurComment As Long, QtyPer, Temp_STR() As String, Output_Array() As Variant, Temp_VAR() As Variant, _
Target_Sheet As Worksheet, Data_Range As Range, Found_Header As Boolean, Data_End As Long, Return1_IfBase0 As Long

Set Target_Sheet = ActiveSheet '<=============[Change this if needed]===================================

Set Data_Range = Target_Sheet.UsedRange

With Data_Range

    If .Columns.Count < 5 Then

        MsgBox "Not enough columns on worksheet: " & Target_Sheet.Name
        Exit Sub

    Else
        WS_D = .Value
    End If

End With

Temp_STR = Split("MtlSeq,Revision,MfgCommen,PurComment,QtyPer", ",") 'Header Names to be found

With WorksheetFunction

    For W = LBound(WS_D, 1) To LBound(WS_D, 1) 'Look for the first item in Temp_STR per row to determine where headers are.
    
        If Not IsError(Application.Match(Temp_STR(0), .Index(WS_D, W, 0), 0)) Then
            Found_Header = True
            Exit For
        End If

    Next W

    If Not Found_Header Then
        GoTo Columns_Not_Found
    Else
        Temp_VAR = .Index(WS_D, W, 0)                 'Make an array from header row.
    
        On Error GoTo Columns_Not_Found               'Find location of header within Temp_VAR. Return error if not found.
    
        MtlSeq = .Match("MtlSeq", Temp_VAR, 0)
        Revision = .Match("Revision", Temp_VAR, 0)
        MfgComment = .Match("MfgComment", Temp_VAR, 0)
        PurComment = .Match("PurComment", Temp_VAR, 0)
        QtyPer = .Match("QtyPer", Temp_VAR, 0)
    
        Return1_IfBase0 = IIf(LBound(Array()) = 1, 0, 1) 'Determine if user has changed option base
    
        Data_Start = W + 1                          'First non-header row
        Data_End = UBound(WS_D, 1)                  'Total number of rows in array..used for loop boundaries and clearing cells
   End If

End With

On Error GoTo 0

For V = Data_Start To Data_End 'loop rows skip headers

    If Not IsEmpty(WS_D(V, MfgComment)) Then

        Temp_STR = Split(WS_D(V, MfgComment), ",")    'Create array by spliiting column MfgComment with a comma

        For W = LBound(Temp_STR) To UBound(Temp_STR)    'Add a new array to collection for each element in the above array
      
            Split_CLCTN.Add Array(WS_D(V, MtlSeq), WS_D(V, Revision), Temp_STR(W), WS_D(V, PurComment), 1)
    
        Next W

    End If

Next V

Temp_VAR = Array(MtlSeq, Revision, MfgComment, PurComment, QtyPer) 'Store header locations in array

With Split_CLCTN

    If .Count = 0 Then GoTo No_Data_MfgComment

    ReDim Output_Array(1 To .Count, LBound(Temp_VAR) To UBound(Temp_VAR))

    For V = 1 To .Count 'Loop items in collection and combine into a singular array

        WS_D = .ITEM(V) 'Load array from collection

        For W = LBound(Temp_VAR) To UBound(Temp_VAR)
            Output_Array(V, W) = WS_D(W)
        Next W

    Next V

End With

Application.ScreenUpdating = False

With Data_Range 'Apply array to worksheet based on heading

    For W = LBound(Temp_VAR) To UBound(Temp_VAR)
  
        With .Cells(Data_Start, Temp_VAR(W))
        
             .Resize(Data_End - Data_Start + 1).ClearContents 'Clear the entire column below headers
        
             .Resize(UBound(Output_Array, 1)).Value2 = WorksheetFunction.Index(Output_Array, 0, W + Return1_IfBase0)
  
        End With
  
    Next W

End With

Application.ScreenUpdating = True

Exit Sub

No_Data_MfgComment:

    MsgBox "No data found in column MfgComment"
    Exit Sub

Columns_Not_Found:
    MsgBox "One or more necessary headers weren't found on worksheet: " & Target_Sheet.Name

End Sub

 

[decadence]

I have tried the last code posted and still getting run time error 13 on this line

If Not IsError(Application.Match(Temp_STR(0), .Index(WS_D, W, 0), 0)) Then

 

[MoshiM]

What happens if you create a new sheet with only the sample data you provided and run the macro? Try changing "With Worksheetfunction" to "With Application". Also How big is your data?

 

[MoshiM]

Sub Split_Stuff()

Dim WS_D() As Variant, Split_CLCTN As New Collection, V As Long, W As Long, MtlSeq As Long, Revision As Long, Data_Start As Long, _
MfgComment As Long, PurComment As Long, QtyPer, Temp_STR() As String, Output_Array() As Variant, Temp_VAR() As Variant, _
Target_Sheet As Worksheet, Data_Range As Range, Found_Header As Boolean, Data_End As Long, Return1_IfBase0 As Long

Set Target_Sheet = ActiveSheet '<=============[Change this if needed]===================================

Set Data_Range = Target_Sheet.UsedRange

With Data_Range

    If .Columns.Count < 5 Then

        MsgBox "Not enough columns on worksheet: " & Target_Sheet.Name
        Exit Sub

    Else
        WS_D = .Value
    End If

End With

Temp_STR = Split("MtlSeq,Revision,MfgCommen,PurComment,QtyPer", ",") 'Header Names to be found

ReDim Temp_VAR(LBound(WS_D, 2) To UBound(WS_D, 2))

With Application

    For W = LBound(WS_D, 1) To UBound(WS_D, 1) 'Look for the first item in Temp_STR per row to determine where headers are.
      
        For V = LBound(WS_D, 2) To UBound(WS_D, 2)
            Temp_VAR(V) = WS_D(W, V)
        Next V
      
        If Not IsError(.Match(Temp_STR(0), Temp_VAR, 0)) Then
            Found_Header = True
            Exit For
        End If

    Next W

    If Not Found_Header Then
        GoTo Columns_Not_Found
    Else
  
        On Error GoTo Columns_Not_Found               'Find location of header within Temp_VAR. Return error if not found.
  
        MtlSeq = .Match("MtlSeq", Temp_VAR, 0)
        Revision = .Match("Revision", Temp_VAR, 0)
        MfgComment = .Match("MfgComment", Temp_VAR, 0)
        PurComment = .Match("PurComment", Temp_VAR, 0)
        QtyPer = .Match("QtyPer", Temp_VAR, 0)
  
        Return1_IfBase0 = IIf(LBound(Array()) = 1, 0, 1) 'Determine if user has changed option base
  
        Data_Start = W + 1                          'First non-header row
        Data_End = UBound(WS_D, 1)                  'Total number of rows in array..used for loop boundaries and clearing cells
   End If

End With

On Error GoTo 0

For V = Data_Start To Data_End 'loop rows skip headers

    If Not IsEmpty(WS_D(V, MfgComment)) Then

        Temp_STR = Split(WS_D(V, MfgComment), ",")    'Create array by spliiting column MfgComment with a comma

        For W = LBound(Temp_STR) To UBound(Temp_STR)    'Add a new array to collection for each element in the above array
    
            Split_CLCTN.Add Array(WS_D(V, MtlSeq), WS_D(V, Revision), Temp_STR(W), WS_D(V, PurComment), 1)
  
        Next W

    End If

Next V

Temp_VAR = Array(MtlSeq, Revision, MfgComment, PurComment, QtyPer) 'Store header locations in array

With Split_CLCTN

    If .Count = 0 Then GoTo No_Data_MfgComment

    ReDim Output_Array(1 To .Count, LBound(Temp_VAR) To UBound(Temp_VAR))

    For V = 1 To .Count 'Loop items in collection and combine into a singular array

        WS_D = .ITEM(V) 'Load array from collection

        For W = LBound(Temp_VAR) To UBound(Temp_VAR)
            Output_Array(V, W) = WS_D(W)
        Next W

    Next V

End With

Application.ScreenUpdating = False

With Data_Range 'Apply array to worksheet based on heading

    For W = LBound(Temp_VAR) To UBound(Temp_VAR)

        With .Cells(Data_Start, Temp_VAR(W))
      
             .Resize(Data_End - Data_Start + 1).ClearContents 'Clear the entire column below headers
      
             .Resize(UBound(Output_Array, 1)).Value2 = application.Index(Output_Array, 0, W + Return1_IfBase0)

        End With

    Next W

End With

Application.ScreenUpdating = True

Exit Sub

No_Data_MfgComment:

    MsgBox "No data found in column MfgComment"
    Exit Sub

Columns_Not_Found:
    MsgBox "One or more necessary headers weren't found on worksheet: " & Target_Sheet.Name

End Sub