Excel VBA Split Rows Trick and Announcement

Today i have to make an announcement: in the near future I intend to migrate the blog to a new one with a new design and completely in english because I want to develop a better project and reach readers from Romania, but also from other countries. The content will remain the same: finance and accounting, Excel automations and apps, SQL, Access etc.

Now, let's talk about an Excel problem which i recently had to solve. In reality i had a worksheet with thousands of rows (so the manual work which could take days wasn't a solution), but for illustrating purposes i created a file with few rows and no confidential data :)

! Challenge: You have the data from Range("A2:E4"). Split the rows by company codes: for Each Company code separated by a character (; or , or / or -) automatically create a new row. The rest of the data from other columns remains the same for the new rows. Every Company Code string can have different lenght and betwen codes and separators can be spaces.

Initial:

Result:

My code for solving this is the following:

Sub split_rows()

'original code by Andrei Lungu

lr = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row

counter_ch = 0
ismore = False

col_comp_code = "C"

Application.ScreenUpdating = False

For i = lr To 2 Step -1

    Set check_cell0 = ActiveSheet.Range(col_comp_code & i)
    
    check_cell = Replace(check_cell0, " ", "")
    
    counter = 0
        For j = 1 To Len(check_cell)
        
            counter_ch = counter_ch + 1
            activechar = Mid(check_cell, j, 1)
            
            If activechar = "," Or activechar = ";" Or activechar = "/" Or activechar = "-" Then
            ismore = True
                Separator = activechar
                
                counter = counter + 1
                ActiveSheet.Rows(i).Offset(0).EntireRow.Insert
                where_starts = j - (counter_ch - 1)
                company_code = Mid(check_cell, where_starts, counter_ch - 1)
                
    
                ActiveSheet.Range(col_comp_code & i) = company_code
                
            counter_ch = 0
            End If
        
        Next j
                
    'last comp code
    If ismore = True Then
    
    'find out the position of the last separator
                    last_sep = counter
                    char_no = 1
                    counter2 = 0
                    For k = 1 To Len(check_cell)
                    
                        activechar2 = Mid(check_cell, k, 1)
                        char_no = char_no + 1
                        If activechar2 = "," Or activechar2 = ";" Or activechar2 = "/" Or activechar2 = "-" Then
                        counter2 = counter2 + 1
                        If counter2 = last_sep Then
                            last_sep_char_no = char_no
                            'MsgBox last_sep_char_no
                        End If
                        
                        End If
                    
                    Next k
            
    'copy last company code
        last_company_code = Right(check_cell, Len(check_cell) - last_sep_char_no + 1)
        ActiveSheet.Range(col_comp_code & i).Offset(counter) = last_company_code
        
    'copy rest of data
        Do While counter > 0
        
        ActiveSheet.Range("A" & i & ":B" & i).Offset(counter).Copy ActiveSheet.Range("A" & i & ":B" & i).Offset(counter - 1)
        ActiveSheet.Range("D" & i & ":E" & i).Offset(counter).Copy ActiveSheet.Range("D" & i & ":E" & i).Offset(counter - 1)
        counter = counter - 1
        Loop
    
    End If
    
    ismore = False
    
        counter_ch = 0
        counter = 0

Next i

Application.ScreenUpdating = False

End Sub

If you have other ideas please share them in a comment.

The sample file can be downloaded from this location.

Subscribe to Un mod diferit de a privi Economia by Email