Insert extra row when Mr & Mrs found then copy data into blank row-CodePudding

So i have data which looks like this:

Name	Title	Salutation
Doe	Mr J & Mrs E	John & Elaine
Smith	Mr K & Mrs M	Ken & Margaret
Jones	Mr R	Bob

I need to identify the rows which contain Mr & Mrs and give them each their own row. So I want it to look like this:

Name	Title	Salutation
Doe	Mr J	John
Doe	Mrs E	Elaine
Smith	Mr K	Ken
Smith	Mrs M	Margaret
Jones	Mr R	Bob

Please could someone help with some code to do this?

CodePudding user response：

The solution below is coded for your three columns to be in Columns A, B, and C. This loop works up from the bottom of your data to make it easier to deal with the inserted row.

Sub split_rows()
    Dim s As Worksheet
    Dim r As Long
    Dim title_position As Integer
    Dim saluation_position As Integer
    Dim title As String
    Dim salutation As String
    Dim last_row As Long
    
    Const name_column = 1
    Const title_column = 2
    Const salutation_column = 3
    
    
    Set s = ActiveSheet 'use the line to process the active sheet
    'set s = worksheets("Sheet1") ' use this line to process a specific sheet
    
    ' this loop works from the bottom of the worksheet up.
    ' the code is simpler that working top-down.
    last_row = s.Cells(s.Rows.Count, title_column).End(xlUp).Row
    For r = last_row To 2 Step -1
        Debug.Print s.Cells(r, 1).Value
        title_position = InStr(1, s.Cells(r, title_column).Value, "&")
        saluation_position = InStr(1, s.Cells(r, salutation_column).Value, "&")
          
        If title_position > 0 And saluation_position > 0 Then
            ' found ampersands in title and salution, let's to split the data
            
            'put joint title and salutation values in variables to make the code easier to read
            title = s.Cells(r, title_column).Value
            salutation = s.Cells(r, salutation_column).Value
            
            s.Rows(r).Insert  ' add a row
            
            ' put the the name (unchanged) in the new row
            s.Cells(r, name_column).Value = s.Cells(r   1, name_column).Value
            
            ' put half the title in each row
            s.Cells(r, title_column).Value = Trim(Split(title, "&")(0))
            s.Cells(r   1, title_column).Value = Trim(Split(title, "&")(1))
            
            ' put half the salutation in each row
            s.Cells(r, salutation_column).Value = Trim(Split(salutation, "&")(0))
            s.Cells(r   1, salutation_column).Value = Trim(Split(salutation, "&")(1))
      End If
    Next


End Sub