String manipulation: Separate cases combined in single cell

[kokkentor]

Hi wizards!
I've put together a macro that turns rows containing more than one case in a single cell into separate rows: Say I have "banana, apple, strawberry, cherry" (i.e. 4 cases of fruit) in one single cell and want each case in separate rows in one and the same column. Simple transposing is not an option (I guess) as my sheet have many columns and thousands of rows with a variety of multiple cases in single cells. (If this may be a reason.)

Anyway, I've put together this macro and it works fine apart from:

-> crashing when finished; reaching the end of the column, i.e. at row 65536. Anyway, that's my assessment.

I'd appreciate help on this. I've tried other looping solutions without success. Seems like the Cells.Find procedure is to blame, but I'm at swim.

I'd also like to solve the counting of case separators otherwise than I have managed to: insert a column with a function I found here on the board.

Any help appreciated! Any other improvements as well

Thanks in advance!


This is the code:

Option Explicit

Sub CombinedCasesSplit()
 Dim Cell As Range
 Dim i As Integer
 Dim NOCaseSep As Integer  'number of case separators
 Dim nCase As Integer      'number of cases/rows
 Dim CaseSep As String

CaseSep = ","

For Each Cell In Range("K:K")
'Find cells with caseseparator:
Cells.Find(What:=CaseSep, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
        xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
    
    'Function to return number of caseseparators (here commas) in the cell
        ' Paste this formula into the "NOCaseSeparators" column (L):
        'ActiveCell.Offset(0,1) = SUMMERPRODUKT(--(LENGDE(K2)-LENGDE(BYTT.UT(K2;CaseSep;""))))
        'CaseSep = ","
        '-Norwegian version of = SUMPRODUCT(--(LEN(K2)-LEN(SUBSTITUTE(K2,CaseSep,""))))
        'see http://www.probabilityof.com/excel.shtml#30
            '-- How to do this without using the extra column (L),
            'i.e. how count the case separators in this sub?

        '//----Copy the row NOCaseSep times below Active row
        NOCaseSep = ActiveCell.Offset(0, 1)
        If NOCaseSep > 0 Then 'ActiveCell.Offset(0, 1) is number of rows /case separators
            For i = 1 To ActiveCell.Offset(0, 1)
                ActiveCell.Offset(1).EntireRow.Insert
                Rows(ActiveCell.Row).Copy
                Rows(ActiveCell.Row).Offset(1).PasteSpecial Paste:=xlPasteAll, _
                    Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Next i
            'Select first of the k-column cells to be "cleaned":
            ActiveCell.Offset(-NOCaseSep, 10).Activate
        End If
        '//----"Clean" combined cases:
        '1st CASE/ROW:
            'keep string left of first case separator:
            ActiveCell _
            = Mid(ActiveCell, 1, InStr(1, ActiveCell, CaseSep) - 1)
        '2nd to penultimate CASE/ROW:
        For nCase = NOCaseSep - 1 To 1 Step -1
            'remove what is left of NOCaseSep-1'th case separator:
            For i = 1 To NOCaseSep - nCase
                ActiveCell.Offset(NOCaseSep - nCase, 0) _
                = Mid(ActiveCell.Offset(NOCaseSep - nCase, 0), InStr(1, ActiveCell.Offset(NOCaseSep - nCase, 0), CaseSep) + 1, 255)
            Next i
            'remove what is right of NOCaseSep'th (last) case separator:
            ActiveCell.Offset(NOCaseSep - nCase, 0) _
            = Mid(ActiveCell.Offset(NOCaseSep - nCase, 0), 1, InStr(1, ActiveCell.Offset(NOCaseSep - nCase, 0), CaseSep) - 1)
        Next nCase
        'ultimate/last CASE/ROW:
        'remove what is left of last case separator:
        For i = 1 To NOCaseSep
            ActiveCell.Offset(NOCaseSep, 0) _
            = Mid(ActiveCell.Offset(NOCaseSep, 0), InStr(1, ActiveCell.Offset(NOCaseSep, 0), CaseSep) + 1, 255)
        Next i
Next Cell

End Sub

 

[Von Pookie]

Would this work for you?

Sub CombinedCasesSplit()
Dim i As Long, y As Long, LastRow As Long
Dim x As Integer, temp As Variant

'find last row with data in column K--this will be stopping point
LastRow = Columns("K:K").Find("*", searchdirection:=xlPrevious).Row

'loop through the column, starting at row 1, stopping at last row found (not entire column
i = 1
Do Until i > LastRow
    'count number of commas in cell
    'determined by finding the difference between the number of characters
    'in the string and the number of characters in the same string with commas removed
    x = Len(Cells(i, "K")) - Len(Replace(Cells(i, "K"), ",", ""))
    
    'if commas are found
    If x > 0 Then
        'save value of cell to variable as comma-delimited array
        temp = Split(Cells(i, "K"), ",")
        
        'insert rows according to how many commas were found
        Rows(i + 1 & ":" & i + x).Insert
        
        'insert the values from the cell into the rows
        For y = LBound(temp) To UBound(temp)
            Cells(i + y, "K") = temp(y)
        Next y
        
        'increase the value of LastRow since rows were added
        LastRow = LastRow + x
        
        'increase the value of i since rows were added
        i = i + x
    End If
    'increase value of i by 1 to loop to the next row in column
    i = i + 1
Loop

End Sub

 

[kokkentor]

Sweet solution, Von Pookie/Kristy!!

Thanks!!

Works nicely, apart from not preserving the other cells' content; it is only manipulating the combined cell, not copying the other cell's content to the new rows.

Perhaps I'll manage that myself tomorrow. It's nighttime here in Norway now, and I have to watch Nadal too...

I really liked your solution - makes use of things new to me, meaning I am learning! And that's always a good thing.

 

[kokkentor]

Kristy, I did a combination of your and mine solution which works fine. Your solution is however more efficient I guess - at least nicer to the eye. I like the array variable - which I should be able to use to copy the content of the other cells as well as the one with commas in.

Thanks again for your help, Kristy!

Sub CombinedCasesSplit()
Dim Cell As Range
Dim i As Integer, j As Integer, NOCaseSep As Integer, nCase As Integer
Dim CaseSep As String, LastRow As Long

CaseSep = ","

LastRow = Columns("K:K").Find("*", searchdirection:=xlPrevious).Row

'loop through the column, starting at row 1, stopping at last row found (not entire column
j = 1
Do Until j > LastRow

    'count number of commas in cell
    'determined by finding the difference between the number of characters
    'in the string and the number of characters in the same string with commas removed
    NOCaseSep = Len(Cells(j, "K")) - Len(Replace(Cells(j, "K"), CaseSep, ""))
    
        '//----Copy the row NOCaseSep times below Active row

        If NOCaseSep > 0 Then
            For i = 1 To NOCaseSep
                Cells(j, "K").Offset(1).EntireRow.Insert
                Rows(Cells(j, "K").Row).Copy
                Rows(Cells(j, "K").Row).Offset(1).PasteSpecial Paste:=xlPasteAll, _
                    Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Next i
        
        '//----"Clean" combined cases:
        '1st case/row; keep string left of first case separator:
            Cells(j, "K") _
            = Mid(Cells(j, "K"), 1, InStr(1, Cells(j, "K"), CaseSep) - 1)
        '2nd to penultimate case/row:
            For nCase = NOCaseSep - 1 To 1 Step -1
                'remove what is left of NOCaseSep-1'th case separator:
                For i = 1 To NOCaseSep - nCase
                    Cells(j, "K").Offset(NOCaseSep - nCase, 0) _
                    = Mid(Cells(j, "K").Offset(NOCaseSep - nCase, 0), InStr(1, Cells(j, "K").Offset(NOCaseSep - nCase, 0), CaseSep) + 1, 255)
                Next i
                'remove what is right of NOCaseSep'th (last) case separator:
                Cells(j, "K").Offset(NOCaseSep - nCase, 0) _
                = Mid(Cells(j, "K").Offset(NOCaseSep - nCase, 0), 1, InStr(1, Cells(j, "K").Offset(NOCaseSep - nCase, 0), CaseSep) - 1)
            Next nCase
        'ultimate/last case/row; remove what is left of last case separator:
            For i = 1 To NOCaseSep
                Cells(j, "K").Offset(NOCaseSep, 0) _
                = Mid(Cells(j, "K").Offset(NOCaseSep, 0), InStr(1, Cells(j, "K").Offset(NOCaseSep, 0), CaseSep) + 1, 255)
            Next i
        '//----"Clean" end ---
        
        'increase the value of LastRow since rows were added:
        LastRow = LastRow + NOCaseSep
        
        'increase the value of i since rows were added:
        j = j + NOCaseSep
        
    End If
    'increase value of j by 1 to loop to the next row in column:
    j = j + 1
Loop

End Sub

 

[Von Pookie]

I am glad it worked!

However, I am confused by how you have "combined" the codes. As far as I can see, my code does the same thing as yours, the only difference being that I am not copying the entire row. Basically, you have a lot of extra steps that you can remove simply by using the array approach I had in my code.

If you need to have the data from the other columns in the row for each item in that cell, you can do that with my original code. You should only have to make one small change so that the original row is copied.

Sub CombinedCasesSplit()
Dim i As Long, y As Long, LastRow As Long
Dim x As Integer, temp As Variant

'find last row with data in column K--this will be stopping point
LastRow = Columns("K:K").Find("*", searchdirection:=xlPrevious).Row

'loop through the column, starting at row 1, stopping at last row found (not entire column
i = 1
Do Until i > LastRow
    'count number of commas in cell
    'determined by finding the difference between the number of characters
    'in the string and the number of characters in the same string with commas removed
    x = Len(Cells(i, "K")) - Len(Replace(Cells(i, "K"), ",", ""))
   
    'if commas are found
    If x > 0 Then
        'save value of cell to variable as comma-delimited array
        temp = Split(Cells(i, "K"), ",")
       
       'copy the original row **this is the only change**
       Rows(i).Copy
       
        'insert copied row below original row according to how many commas were found
        Rows(i + 1 & ":" & i + x).Insert
       
        'insert the values from the cell into the rows
        For y = LBound(temp) To UBound(temp)
            Cells(i + y, "K") = temp(y)
        Next y
       
        'increase the value of LastRow since rows were added
        LastRow = LastRow + x
       
        'increase the value of i since rows were added
        i = i + x
    End If
    'increase value of i by 1 to loop to the next row in column
    i = i + 1
Loop

End Sub

 

[kokkentor]

Don't be confused - I am the confused one.
Your solution is of course the better one, and I'll use that one. It was just that I wasn't comfortable with the array - which I've never used - and uncertain whether it would work when copying the row. It's just because I'm a novice.
Thanks and have a nice weekend!

 

[Von Pookie]

Oh--I didn't mean to imply it was actually *better*, but I was just confused by the way you combined the codes--using some parts but not others I would expect to be used.

In the end, just use whatever you're comfortable with. It is your file, after all

 

[kokkentor]

I think its actually better. The smaller /more efficient code the better.