Macro Help: Duplicate Single Row of Data into multiple, one line each family member

J

jeffcoleky

Active Member
Joined
May 24, 2011
Messages
274
Objective:
Using the data in a single row, create a new row for each member of the family (spouse and up to 16 children). Use their name, phone, and email address from the existing row (if value exists). Also Duplicate the address (modified), group number, and head of household's name in each row.

I have created a basic set of data, and the desired outcome in a spreadsheet. I also have a larger set of live data you can use to try it out. The spreadsheet with all the data can be found here. ROW IS TOO LONG TO POST HERE: https://docs.google.com/spreadsheets/d/15vOY_D7OW_MKSuq28sKEZv24eXg1bNoQboMol5QD-LY/edit?usp=sharing

Here are the steps that take place (I'm not a coder and don't know proper terminology but think this is how it should work)
1 If head of house has a spouse (Column E), create blank row below current row for her info.
2 Also create an additional blank row for each child name if a name is found in columns F, H, K, N, Q, T, W, Z, AC, AF, AI, AL, AO, AR, AU, AX, BC. (child names are inserted in order if they exist so if F is blank, then you know H-BC are blank also)
3 Insert the Head of Household's name in Column A for each of the newly created rows
4 Insert the Group Number found in Column BD, into column I, for each of the newly created rows
5 insert the head of household's name (From Col B) into first row of column C for that family.
6 Insert Head of Household's email address (from Column D) into the first row of column E for that family.
7 Insert Head of Household's Phone Number (from Column C) into the first row of column F for that family.
8A If Spouse Name exists:
8B Insert the spouses's full name (from Column E) into the first row of Column B for that family.
8C Insert the spouses's full name (from Column E) into the Second row, Column C for that family.
8D Insert the spouse's email address (From Column G) into second row of Column E
8E Insert the spouse's Phone Number (from Column F) into the second row of Column F.
8F If Spouse Name does not exist, goto first child name.
9A If child name exists in F
9B Copy Name from F into next empty row in column C
9C Copy child's email address from J into column E
9D Copy Child's Phone Number from column I into Column F
9E Repeat the if child name exists rule for each child thereafter.
9F If no child name exists in F, goto next step
10 Extract the FIRST 5 numbers in the zip code and insert the value into column H for each member of the family
11 Extract the street name and city from the address and insert into column G for each member of the family. (State is always surrounded by two commas)

It is way too complcated for me... if anyone can tackle this it would be greatly appreciated, it's for a non-profit church group. Thanks!
 

Excel Facts

Why does 9 mean SUM in SUBTOTAL?
It is because Sum is the 9th alphabetically in Average, Count, CountA, Max, Min, Product, StDev.S, StDev.P, Sum, VAR.S, VAR.P.
Sort by date Sort by votes
It is way too complcated for me... if anyone can tackle this it would be greatly appreciated, it's for a non-profit church group. Thanks!
Click to expand...

jeffcoleky,
For legibility, it appears that a blank row between families would be helpful. If you want a blank row, then uncomment the line of code in red font… ie. remove the single quote at the beginning. I named my sheets 'Input' and 'Output'. Change those names to your sheet names wherever they occur in the code below.

To use this code enter the Visual Basic Editor by pressing Alt+F11, then copy the code into the large window. Close the Editor window and save the file as macro enabled. Test this code on a copy of your file so you don't lose any important data. Depending on the version of Excel you are using you might have to enable macros before running the code. To run the code press Alt+F8, select 'MakeFamilyRows' from the dialog window that opens, then 'Run'.
Perpa

Code: 
Sub MakeFamilyRows()
Dim col, LastRow, rw1, rw2, rwS As Long
'Dim myAdd As String
'rw1 is on Sheet "Input"
'rw2 is on Sheet "Output"
LastRow = Sheets("Input").Cells(Rows.Count, "B").End(xlUp).Row
rw2 = 2
    For rw1 = 2 To LastRow
    
        With Sheets("Output")
            .Cells(rw2, "A") = Sheets("Input").Cells(rw1, "E")   'Spouses Name
            .Cells(rw2, "B") = Sheets("Input").Cells(rw1, "B")   'Invidual's Full Name
            .Cells(rw2, "D") = Sheets("Input").Cells(rw1, "D")   'email
            .Cells(rw2, "E") = Sheets("Input").Cells(rw1, "C")   'Phone Number
            myAdd = Sheets("Input").Range("A" & rw1).Value
            If myAdd = "" Then GoTo NOADD
            .Cells(rw2, "F") = Left(myAdd, InStrRev(myAdd, ",") - 1)    'Street & City
           .Cells(rw2, "G") = Right(myAdd, Len(myAdd) - Len(Left(myAdd, InStrRev(myAdd, "Michigan") + 8)))      'Zip
NOADD:
            .Cells(rw2, "H") = Sheets("Input").Cells(rw1, "BD")         'Group
        
        'Do the following for each family
            rwS = rw2 + 1
            For col = 5 To 53 Step 3     'Steps through the Spouse and other dependants until a blank is encountered in the 'Name' column
                If Sheets("Input").Cells(rw1, col) = "" Then GoTo PASSEM
                If Sheets("Input").Cells(rw1, col) <> "" Then
                    .Cells(rwS, "B") = Sheets("Input").Cells(rw1, col)    'Name
                    .Cells(rwS, "D") = Sheets("Input").Cells(rw1, col + 2) 'email
                    .Cells(rwS, "E") = Sheets("Input").Cells(rw1, col + 1)  'phone
                    .Cells(rwS, "F") = Cells(rw2, "F")   'Street & City
                    .Cells(rwS, "G") = Cells(rw2, "G")   'Zip
                    .Cells(rwS, "H") = Cells(rw2, "H")   'Group
                    rwS = rwS + 1
                 End If
                 
            Next col
        End With
PASSEM:
    [COLOR=#ff0000]'rwS = rwS + 1[/COLOR]
    rw2 = rwS
Next rw1
    Sheets("Output").Columns("A:H").Columns.AutoFit
    Sheets("Output").Range("A1").Select
End Sub
 
Upvote 0
WOW! That's almost perfect! Sorry for the delayed response. There are only two small problems:

  1. Rule #3 above: Insert the Head of Household's name in Column A for each of the newly created rows (every row has a head of house, so should be no blanks in A). Currently col A is accidentally being used for spouse name.
  2. Rule 8F above: "If Spouse Name does not exist, goto first child name." This means that when there is no spouse but they do have children, we still need the kid's names populated. The way it is now, it seems to skip the children if the spouse is blank.

Can you please tweak it for these requirements?

Perpa said:
jeffcoleky,
For legibility, it appears that a blank row between families would be helpful. If you want a blank row, then uncomment the line of code in red font… ie. remove the single quote at the beginning. I named my sheets 'Input' and 'Output'. Change those names to your sheet names wherever they occur in the code below.

To use this code enter the Visual Basic Editor by pressing Alt+F11, then copy the code into the large window. Close the Editor window and save the file as macro enabled. Test this code on a copy of your file so you don't lose any important data. Depending on the version of Excel you are using you might have to enable macros before running the code. To run the code press Alt+F8, select 'MakeFamilyRows' from the dialog window that opens, then 'Run'.
Perpa

Code: 
Sub MakeFamilyRows()
Dim col, LastRow, rw1, rw2, rwS As Long
'Dim myAdd As String
'rw1 is on Sheet "Input"
'rw2 is on Sheet "Output"
LastRow = Sheets("Input").Cells(Rows.Count, "B").End(xlUp).Row
rw2 = 2
    For rw1 = 2 To LastRow
    
        With Sheets("Output")
            .Cells(rw2, "A") = Sheets("Input").Cells(rw1, "E")   'Spouses Name
            .Cells(rw2, "B") = Sheets("Input").Cells(rw1, "B")   'Invidual's Full Name
            .Cells(rw2, "D") = Sheets("Input").Cells(rw1, "D")   'email
            .Cells(rw2, "E") = Sheets("Input").Cells(rw1, "C")   'Phone Number
            myAdd = Sheets("Input").Range("A" & rw1).Value
            If myAdd = "" Then GoTo NOADD
            .Cells(rw2, "F") = Left(myAdd, InStrRev(myAdd, ",") - 1)    'Street & City
           .Cells(rw2, "G") = Right(myAdd, Len(myAdd) - Len(Left(myAdd, InStrRev(myAdd, "Michigan") + 8)))      'Zip
NOADD:
            .Cells(rw2, "H") = Sheets("Input").Cells(rw1, "BD")         'Group
        
        'Do the following for each family
            rwS = rw2 + 1
            For col = 5 To 53 Step 3     'Steps through the Spouse and other dependants until a blank is encountered in the 'Name' column
                If Sheets("Input").Cells(rw1, col) = "" Then GoTo PASSEM
                If Sheets("Input").Cells(rw1, col) <> "" Then
                    .Cells(rwS, "B") = Sheets("Input").Cells(rw1, col)    'Name
                    .Cells(rwS, "D") = Sheets("Input").Cells(rw1, col + 2) 'email
                    .Cells(rwS, "E") = Sheets("Input").Cells(rw1, col + 1)  'phone
                    .Cells(rwS, "F") = Cells(rw2, "F")   'Street & City
                    .Cells(rwS, "G") = Cells(rw2, "G")   'Zip
                    .Cells(rwS, "H") = Cells(rw2, "H")   'Group
                    rwS = rwS + 1
                 End If
                 
            Next col
        End With
PASSEM:
    [COLOR=#ff0000]'rwS = rwS + 1[/COLOR]
    rw2 = rwS
Next rw1
    Sheets("Output").Columns("A:H").Columns.AutoFit
    Sheets("Output").Range("A1").Select
End Sub
Click to expand...
Perpa said:
jeffcoleky,
For legibility, it appears that a blank row between families would be helpful. If you want a blank row, then uncomment the line of code in red font… ie. remove the single quote at the beginning. I named my sheets 'Input' and 'Output'. Change those names to your sheet names wherever they occur in the code below.

To use this code enter the Visual Basic Editor by pressing Alt+F11, then copy the code into the large window. Close the Editor window and save the file as macro enabled. Test this code on a copy of your file so you don't lose any important data. Depending on the version of Excel you are using you might have to enable macros before running the code. To run the code press Alt+F8, select 'MakeFamilyRows' from the dialog window that opens, then 'Run'.
Perpa

Code: 
Sub MakeFamilyRows()
Dim col, LastRow, rw1, rw2, rwS As Long
'Dim myAdd As String
'rw1 is on Sheet "Input"
'rw2 is on Sheet "Output"
LastRow = Sheets("Input").Cells(Rows.Count, "B").End(xlUp).Row
rw2 = 2
    For rw1 = 2 To LastRow
    
        With Sheets("Output")
            .Cells(rw2, "A") = Sheets("Input").Cells(rw1, "E")   'Spouses Name
            .Cells(rw2, "B") = Sheets("Input").Cells(rw1, "B")   'Invidual's Full Name
            .Cells(rw2, "D") = Sheets("Input").Cells(rw1, "D")   'email
            .Cells(rw2, "E") = Sheets("Input").Cells(rw1, "C")   'Phone Number
            myAdd = Sheets("Input").Range("A" & rw1).Value
            If myAdd = "" Then GoTo NOADD
            .Cells(rw2, "F") = Left(myAdd, InStrRev(myAdd, ",") - 1)    'Street & City
           .Cells(rw2, "G") = Right(myAdd, Len(myAdd) - Len(Left(myAdd, InStrRev(myAdd, "Michigan") + 8)))      'Zip
NOADD:
            .Cells(rw2, "H") = Sheets("Input").Cells(rw1, "BD")         'Group
        
        'Do the following for each family
            rwS = rw2 + 1
            For col = 5 To 53 Step 3     'Steps through the Spouse and other dependants until a blank is encountered in the 'Name' column
                If Sheets("Input").Cells(rw1, col) = "" Then GoTo PASSEM
                If Sheets("Input").Cells(rw1, col) <> "" Then
                    .Cells(rwS, "B") = Sheets("Input").Cells(rw1, col)    'Name
                    .Cells(rwS, "D") = Sheets("Input").Cells(rw1, col + 2) 'email
                    .Cells(rwS, "E") = Sheets("Input").Cells(rw1, col + 1)  'phone
                    .Cells(rwS, "F") = Cells(rw2, "F")   'Street & City
                    .Cells(rwS, "G") = Cells(rw2, "G")   'Zip
                    .Cells(rwS, "H") = Cells(rw2, "H")   'Group
                    rwS = rwS + 1
                 End If
                 
            Next col
        End With
PASSEM:
    [COLOR=#ff0000]'rwS = rwS + 1[/COLOR]
    rw2 = rwS
Next rw1
    Sheets("Output").Columns("A:H").Columns.AutoFit
    Sheets("Output").Range("A1").Select
End Sub
Click to expand...
 
Upvote 0
jeffcoleky said:
WOW! That's almost perfect! Sorry for the delayed response. There are only two small problems:

  1. Rule #3 above: Insert the Head of Household's name in Column A for each of the newly created rows (every row has a head of house, so should be no blanks in A). Currently col A is accidentally being used for spouse name.
  2. Rule 8F above: "If Spouse Name does not exist, goto first child name." This means that when there is no spouse but they do have children, we still need the kid's names populated. The way it is now, it seems to skip the children if the spouse is blank.

Can you please tweak it for these requirements?
Click to expand...

jfeffcoleky,
Good to hear back from you. I made the two tweaks you requested, plus I added a line to remove the last 4 digits of a Zip code if the Zip code is like '99444-2233', now you will only get the first 5 numbers, '99444'.
This revised code should do what you want. The only caviat is that the children's names MUST start in column H (column 8) with no blanks in columns 11, 14, 17 and etc to column 53. When a blank is encountered in one of those columns the macro skips to the next Head of Household.
I trust this does what you need.
Perpa
Code: 
Sub MakeFamilyRows2()
Dim col, LastRow, rw1, rw2, rwS As Long
Dim myAdd As String
'rw1 is on Sheet "Input"
'rw2 is on Sheet "Output"
LastRow = Sheets("Input").Cells(Rows.Count, "B").End(xlUp).Row
rw2 = 2
    For rw1 = 2 To LastRow
    
        With Sheets("Output")
            .Cells(rw2, "A") = Sheets("Input").Cells(rw1, "B")   'Spouses Name
            .Cells(rw2, "B") = Sheets("Input").Cells(rw1, "B")   'Invidual's Full Name
            .Cells(rw2, "D") = Sheets("Input").Cells(rw1, "D")   'email
            .Cells(rw2, "E") = Sheets("Input").Cells(rw1, "C")   'Phone Number
            myAdd = Sheets("Input").Range("A" & rw1).Value
            If myAdd = "" Then GoTo NOADD
            .Cells(rw2, "F") = Left(myAdd, InStrRev(myAdd, ",") - 1)    'Street & City
            .Cells(rw2, "G") = Right(myAdd, Len(myAdd) - Len(Left(myAdd, InStrRev(myAdd, "Michigan") + 8)))      'Zip
            'The next line strips last 4 numbers and the dash if the Zip is like '92222-4455'
            If Len(.Cells(rw2, "G")) > 5 Then .Cells(rw2, "G") = Left(.Cells(rw2, "G"), 5)
NOADD:
            .Cells(rw2, "H") = Sheets("Input").Cells(rw1, "BD")         'Group
        
        'Do the following for each family
            rwS = rw2 + 1
            For col = 5 To 53 Step 3     'Steps through the Spouse and other dependants until a blank is encountered in the 'Name' column
                If Sheets("Input").Cells(rw1, col) = "" And col = 5 Then GoTo NOSPOUSE
                If Sheets("Input").Cells(rw1, col) = "" And col >= 8 Then GoTo PASSEM
                .Cells(rwS, "A") = Sheets("Input").Cells(rw1, "B")   'Head of Household's Name
                .Cells(rwS, "B") = Sheets("Input").Cells(rw1, col)    'Name
                .Cells(rwS, "D") = Sheets("Input").Cells(rw1, col + 2) 'email
                .Cells(rwS, "E") = Sheets("Input").Cells(rw1, col + 1)  'phone
                .Cells(rwS, "F") = Cells(rw2, "F")   'Street & City
                .Cells(rwS, "G") = Cells(rw2, "G")   'Zip
                .Cells(rwS, "H") = Cells(rw2, "H")   'Group
                rwS = rwS + 1
NOSPOUSE:
            Next col
        End With
PASSEM:
    rw2 = rwS
Next rw1
    Sheets("Output").Columns("A:H").Columns.AutoFit
    Sheets("Output").Activate
End Sub
 
Upvote 0
Yes! That is perfect! thank you! Have a great day/week/month/year/life :)



Perpa said:
jfeffcoleky,
Good to hear back from you. I made the two tweaks you requested, plus I added a line to remove the last 4 digits of a Zip code if the Zip code is like '99444-2233', now you will only get the first 5 numbers, '99444'.
This revised code should do what you want. The only caviat is that the children's names MUST start in column H (column 8) with no blanks in columns 11, 14, 17 and etc to column 53. When a blank is encountered in one of those columns the macro skips to the next Head of Household.
I trust this does what you need.
Perpa
Code: 
Sub MakeFamilyRows2()
Dim col, LastRow, rw1, rw2, rwS As Long
Dim myAdd As String
'rw1 is on Sheet "Input"
'rw2 is on Sheet "Output"
LastRow = Sheets("Input").Cells(Rows.Count, "B").End(xlUp).Row
rw2 = 2
    For rw1 = 2 To LastRow
    
        With Sheets("Output")
            .Cells(rw2, "A") = Sheets("Input").Cells(rw1, "B")   'Spouses Name
            .Cells(rw2, "B") = Sheets("Input").Cells(rw1, "B")   'Invidual's Full Name
            .Cells(rw2, "D") = Sheets("Input").Cells(rw1, "D")   'email
            .Cells(rw2, "E") = Sheets("Input").Cells(rw1, "C")   'Phone Number
            myAdd = Sheets("Input").Range("A" & rw1).Value
            If myAdd = "" Then GoTo NOADD
            .Cells(rw2, "F") = Left(myAdd, InStrRev(myAdd, ",") - 1)    'Street & City
            .Cells(rw2, "G") = Right(myAdd, Len(myAdd) - Len(Left(myAdd, InStrRev(myAdd, "Michigan") + 8)))      'Zip
            'The next line strips last 4 numbers and the dash if the Zip is like '92222-4455'
            If Len(.Cells(rw2, "G")) > 5 Then .Cells(rw2, "G") = Left(.Cells(rw2, "G"), 5)
NOADD:
            .Cells(rw2, "H") = Sheets("Input").Cells(rw1, "BD")         'Group
        
        'Do the following for each family
            rwS = rw2 + 1
            For col = 5 To 53 Step 3     'Steps through the Spouse and other dependants until a blank is encountered in the 'Name' column
                If Sheets("Input").Cells(rw1, col) = "" And col = 5 Then GoTo NOSPOUSE
                If Sheets("Input").Cells(rw1, col) = "" And col >= 8 Then GoTo PASSEM
                .Cells(rwS, "A") = Sheets("Input").Cells(rw1, "B")   'Head of Household's Name
                .Cells(rwS, "B") = Sheets("Input").Cells(rw1, col)    'Name
                .Cells(rwS, "D") = Sheets("Input").Cells(rw1, col + 2) 'email
                .Cells(rwS, "E") = Sheets("Input").Cells(rw1, col + 1)  'phone
                .Cells(rwS, "F") = Cells(rw2, "F")   'Street & City
                .Cells(rwS, "G") = Cells(rw2, "G")   'Zip
                .Cells(rwS, "H") = Cells(rw2, "H")   'Group
                rwS = rwS + 1
NOSPOUSE:
            Next col
        End With
PASSEM:
    rw2 = rwS
Next rw1
    Sheets("Output").Columns("A:H").Columns.AutoFit
    Sheets("Output").Activate
End Sub
Click to expand...
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
vba to sum up each column for each employee on column (A)
Replies
6
Views
299
kvsrinivasamurthy
K
L
  • Question Question
Macro to correct entries across multiple sheets
Replies
1
Views
108
Lux Aeterna
L
J
  • Question Question
Group last name based on range in alphabet
Replies
2
Views
102
Peter_SSs
Peter_SSs
Q
  • Question Question
Macro needed to insert 4 rows in table, copy data from above, copy data from another sheet and paste special (transpose values) to those new rows...re
Replies
1
Views
229
sijpie
sijpie
W
  • Question Question
Macro/VBA code code for creating new excel file for each pivot table from a column filter
Replies
1
Views
357
Anthony47
A

Forum statistics

Threads
1,223,238
Messages
6,170,939
Members
452,368
Latest member
jayp2104

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top