Delimit and create a loop in VBA for a varible number in each row

[MrPink1986]

Hi there,
I have a data set where in column J and K I have data which is separated by ; - the data which is A-I is relatable to what is in these columns.
I would like to delimit that data in both these columns which will have the same number of data elements in each and then create a line for each element which was delimited and add the data from A-I for each data element and repeat the process for over 8k rows.

In the below example I would like the first line to only contain cat and Mon then a new line created and inserted with all information up to H with god and Tue and finally the process repeated with all information up to H with sheep and Wed. These columns will have a varying number of elements and it wont always be three.

Thaks in advance.

a

b

c

d

e

f

g

h

cat;dog;sheep

Mon,Tue,Wed

 

[QuietRiot]

Sub SplitAnimals()
    Dim LastRow As Long
    Dim Animals() As String, Days() As String
    
    Application.ScreenUpdating = False
    
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    For i = LastRow To 2 Step -1
        Animals = Split(Range("I" & i).Value, ";")
        Days = Split(Range("J" & i).Value, ",")
        
        If UBound(Animals, 1) > 0 Then
            Rows(i + 1 & ":" & i + UBound(Animals, 1)).Insert Shift:=xlShiftDown
            Range("A" & i & ":H" & i).AutoFill Destination:=Range("A" & i & ":H" & i + UBound(Animals, 1)), Type:=xlFillDefault
            For j = 0 To UBound(Animals, 1)
                Range("I" & i + j) = Trim(Animals(j))
                Range("J" & i + j) = Trim(Days(j))
            Next j
        End If
    Next

    Application.ScreenUpdating = True
End Sub

 

[Norie]

Try this, it will put the result on a new sheet.

Sub DoStuffWithAnimals()
Dim arrIn As Variant
Dim arrOut As Variant
Dim cnt As Long
Dim idx As Long
Dim idxCol As Long
Dim idxRow As Long
Dim arrAnimals As Variant
Dim arrDays As Variant

    arrIn = Range("A1").CurrentRegion
    
    ReDim arrOut(1 To 10000, 1 To 10)
    
    For idxRow = LBound(arrIn, 1) + 1 To UBound(arrIn, 1)
    
        arrAnimals = Split(arrIn(idxRow, 9), ";")
        arrDays = Split(arrIn(idxRow, 10), ";")
        
        For idx = LBound(arrAnimals) To UBound(arrAnimals)
            cnt = cnt + 1
            
            arrOut(cnt, 9) = arrAnimals(idx)
            arrOut(cnt, 10) = arrDays(idx)
            
            For idxCol = LBound(arrIn, 2) To UBound(arrIn, 2) - 2
                arrOut(cnt, idxCol) = arrIn(idxRow, idxCol)
            Next idxCol
            
        Next idx
        
    Next idxRow
    
    Sheets.Add
    
    Range("A1").Resize(cnt, UBound(arrOut, 2)).Value = arrOut
    
End Sub

 

[MrPink1986]

Try this, it will put the result on a new sheet.

Sub DoStuffWithAnimals()
Dim arrIn As Variant
Dim arrOut As Variant
Dim cnt As Long
Dim idx As Long
Dim idxCol As Long
Dim idxRow As Long
Dim arrAnimals As Variant
Dim arrDays As Variant

    arrIn = Range("A1").CurrentRegion
   
    ReDim arrOut(1 To 10000, 1 To 10)
   
    For idxRow = LBound(arrIn, 1) + 1 To UBound(arrIn, 1)
   
        arrAnimals = Split(arrIn(idxRow, 9), ";")
        arrDays = Split(arrIn(idxRow, 10), ";")
       
        For idx = LBound(arrAnimals) To UBound(arrAnimals)
            cnt = cnt + 1
           
            arrOut(cnt, 9) = arrAnimals(idx)
            arrOut(cnt, 10) = arrDays(idx)
           
            For idxCol = LBound(arrIn, 2) To UBound(arrIn, 2) - 2
                arrOut(cnt, idxCol) = arrIn(idxRow, idxCol)
            Next idxCol
           
        Next idx
       
    Next idxRow
   
    Sheets.Add
   
    Range("A1").Resize(cnt, UBound(arrOut, 2)).Value = arrOut
   
End Sub

Hi Norie,

Thanks for the reply - I have tried this code and it works (kinda)

My data has just over 8k rows and when I run the script it gets to a point and gives me an error message stating
Run Time Error '9'
Subscript out of range

The error is pointing at a specific row with a certain mane in the column - this is in the same format as the ones preceding it and I cant understand why it fails.


Also the script returns the residual line with no data for animal or day - ideally I would not want this line created.
So in the example I initial created the script is returning 4 lines - 3 of these lines have one element in columns I and J however he 4th line (as there is only 3 data elements) returns a line with no information in these columns - ideally it should only create the 3 lines and not a forth using this example.

 

[Norie]

I set an arbritray row limit here of 10000.

ReDim arrOut(1 To 10000, 1 To 10)

Try changing that to this.

    ReDim arrOut(1 To 10000, 1 To 10)

As for the other problem, I used dummy data based on the data you posted and I didn't get any 'residual' lines.

 

[MrPink1986]

Sub SplitAnimals()
    Dim LastRow As Long
    Dim Animals() As String, Days() As String
   
    Application.ScreenUpdating = False
   
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
   
    For i = LastRow To 2 Step -1
        Animals = Split(Range("I" & i).Value, ";")
        Days = Split(Range("J" & i).Value, ",")
       
        If UBound(Animals, 1) > 0 Then
            Rows(i + 1 & ":" & i + UBound(Animals, 1)).Insert Shift:=xlShiftDown
            Range("A" & i & ":H" & i).AutoFill Destination:=Range("A" & i & ":H" & i + UBound(Animals, 1)), Type:=xlFillDefault
            For j = 0 To UBound(Animals, 1)
                Range("I" & i + j) = Trim(Animals(j))
                Range("J" & i + j) = Trim(Days(j))
            Next j
        End If
    Next

    Application.ScreenUpdating = True
End Sub

Hi QuiteRiot

Thanks for the reply.

I have tried that script however I have not made progress with it - I have a runtime 9 error Subscript out of range.
It fails and no data is created - when I step though the loop I can see some lines be added to the bottom of the data however for example if I have 3 elements to be delimited it is creating 4 lines though the delimited data is not been pulled correctly into the right columns and also there is a residual line been created also.

Any suggestions?

 

[MrPink1986]

I set an arbritray row limit here of 10000.

ReDim arrOut(1 To 10000, 1 To 10)

Try changing that to this.

    ReDim arrOut(1 To 10000, 1 To 10)

As for the other problem, I used dummy data based on the data you posted and I didn't get any 'residual' lines.

Perfect that allowed the script to run to completetion - I updated the limit to 100000.

It seems to be the case for when there is data to be delimited in I or J this is done correctly - all the data from A- H is included in the line with one data element which has been delimited.
It does seem to spill over and create an additional line based on only the data from A-H and the columns I and J are blank as there is no data from the delimited process.
This does not occur when there is only one data element in columns I/J.

I have headers in my sheet - will this cause the issue?
My data begins in Row2?

 

[Norie]

It tested with headers so that's not the problem.

Do any of the rows have values in columns I or J that end with a ';'?

e.g. cat;dog;sheep;

 

[QuietRiot]

I ran a bunch of test data and it working fine. Only thing i can think of is you might have semicolon or comma mismatches. Like a comma in I instead of a semicolon and a semicolon in j insead of a comma. Also it wont work if there is a mismatch of items between I and J

 

[MrPink1986]

It tested with headers so that's not the problem.

Do any of the rows have values in columns I or J that end with a ';'?

e.g. cat;dog;sheep;

Yes the last character in each cell contains a ";" - I presume it thinks it needs a new line based on this?