Populate dynamic columns - excel

Question

I have a VBA script that currently matches Household IDs in two different worksheets (Children and Adults). If there is a match, the Adults worksheet is populated with the child's date of birth (DOB).
However, the adult can have multiple children and I need the all children's DOBs from the same household on separate consecutive columns in the adult's sheet depending on the number of children (Child DOB1, Child DOB2, etc.).
The VBA needs to be dynamic with no hard-coded column references since column locations can change. However, the column names (ex., Household ID) will always be the same.
It's also possible for more than one adult to be part of a household and I need each adult to have the same list of children DOBs.
Any suggestions would be much appreciated. I am limited in my VBA knowledge so any explanations or comments are helpful. Thank you!
Dim shtA As Worksheet
Dim shtC As Worksheet
Set shtA = ActiveWorkbook.Sheets("Adults")
Set shtC = ActiveWorkbook.Sheets("Children")
'Loop through heading row and get column number of "Household ID" column in "Adults" worksheet
'which will be used to match "Household ID" in the "Children" worksheet
Dim lastCol1 As Long
lastCol1 = shtA.Cells(1, Columns.Count).End(xlToLeft).Column
Dim hid1 As Long
Dim aa As Long
For aa = 1 To lastCol1
If LCase(shtA.Cells(1, aa).Value) = "household id" Then
hid1 = aa
Exit For
End If
Next aa
Dim lastCol As Long
lastCol = shtC.Cells(1, Columns.Count).End(xlToLeft).Column
Dim hid As Long
Dim dob As Long
Dim mm As Long
For mm = 1 To lastCol
If LCase(shtC.Cells(1, mm).Value) = "household id" Then
hid = mm
ElseIf LCase(shtC.Cells(1, mm).Value) = "dob" Then
dob = mm
End If
Next mm
'Begin populate new cols for Adults worksheet
Dim lastSRow As Long
Dim lastDRow As Long
Dim z As Long
Dim zz As Long
lastSRow = shtC.Cells(Rows.Count, 1).End(xlUp).Row 'get last row of source sheet
lastDRow = shtA.Cells(Rows.Count, 1).End(xlUp).Row 'get last row of destination sheet
'Would like to have all children in a household on separate columns in the "Adults" sheet
'Currently, only one child's DOB appears in one column named "Child DOB1"
'but I'd like subsequent columns, "Child DOB2", "Child DOB3", etc.
For z = 2 To lastDRow
For zz = 2 To lastSRow
If shtA.Cells(z, hid1).Value = shtC.Cells(zz, hid).Value Then
shtA.Cells(z, lastCol1 + 1).Value = shtC.Cells(zz, dob).Value
End If
Next zz
Next z
'add heading
shtA.Cells(1, lastCol1 + 1).Value = "Child DOB1"

Answer 1

You are missing a dynamic counter in your last netsted loops. Please try this code. I have taken the liberty and abstracted out getting column numbers in a function (one of the functions I almost always have in my applications).
Please note for this code to work, you have to add by hand "Child DOB1" in your Adults sheet.
Please also note how I saved the headings in a variant before looping: This helps the performance of the function. You can do something similar the rest of the code if you have large data.
Sub PopulateDOBs()
Dim shtA As Worksheet
Dim shtC As Worksheet
Set shtA = ActiveWorkbook.Sheets("Adults")
Set shtC = ActiveWorkbook.Sheets("Children")
Dim hid1 As Long
hid1 = GetColNo("household id", "Adults", 1)
Dim hid As Long
Dim dob As Long
hid = GetColNo("household id", "Children", 1)
dob = GetColNo("dob", "Children", 1)
'Begin populate new cols for Adults worksheet
Dim lastSRow As Long
Dim lastDRow As Long
Dim z As Long
Dim zz As Long
lastSRow = shtC.Cells(Rows.Count, 1).End(xlUp).Row 'get last row of source sheet
lastDRow = shtA.Cells(Rows.Count, 1).End(xlUp).Row 'get last row of destination sheet
Dim dob1Col As Long
Dim j As Long ' the missing counter I mentioned
dob1Col = GetColNo("Child DOB1", "Adults", 1)
For z = 2 To lastDRow
j = -1
For zz = 2 To lastSRow
If shtA.Cells(z, hid1).Value = shtC.Cells(zz, hid).Value Then
j = j + 1
shtA.Cells(z, dob1Col + j).Value = shtC.Cells(zz, dob).Value
'Add heading if missing
If shtA.Cells(1, dob1Col + j).Value <> "Child DOB" & (j + 1) Then
shtA.Cells(1, dob1Col + j).Value = "Child DOB" & (j + 1)
End If
End If
Next zz
Next z
End Sub
Function GetColNo(sHeading As String, sSheetName As String, lHeadingsRow As Long) As Long
Dim vHeadings As Variant
Dim lLastCol As Long
Dim j As Long
With ThisWorkbook.Sheets(sSheetName)
lLastCol = .Cells(lHeadingsRow, Columns.Count).End(xlToLeft).Column
vHeadings = .Range(.Cells(lHeadingsRow, 1), .Cells(lHeadingsRow, lLastCol)).Value
GetColNo = 0
For j = 1 To lLastCol
If LCase(vHeadings(1, j)) = LCase(sHeading) Then
GetColNo = j
Exit Function
End If
Next j
End With
End Function

Answer 2

Try this code using FIND rather than looking at each row/column. It also assumes that there's no Adult Household DOB columns present when starting.
Public Sub Test()
Dim Adult As Worksheet
Dim Children As Worksheet
Set Adult = ThisWorkbook.Worksheets("Adults")
Set Children = ThisWorkbook.Worksheets("Children")
'Find Household ID in Adult sheet.
With Adult.Rows(1)
Dim AdultHouseholdID As Range
Set AdultHouseholdID = .Find(What:="household id", After:=.Cells(1), LookIn:=xlValues, _
LookAt:=xlWhole, SearchDirection:=xlNext, MatchCase:=False)
If AdultHouseholdID Is Nothing Then Exit Sub
'Find the last column in Adult sheet.
'This doesn't check if there's already DOB columns in the sheet.
Dim AdultLastColumn As Range
Set AdultLastColumn = .Cells(1, .Cells.Count).End(xlToLeft)
End With
With Children.Rows(1)
'Find Household ID in Children sheet.
Dim ChildHouseholdID As Range
Set ChildHouseholdID = .Find(What:="household id", After:=.Cells(1), LookIn:=xlValues, _
LookAt:=xlWhole, SearchDirection:=xlNext, MatchCase:=False)
If ChildHouseholdID Is Nothing Then Exit Sub
'Find DOB column in Children sheet.
Dim ChildDOBColumn As Range
Set ChildDOBColumn = .Find(What:="DOB", After:=.Cells(1), LookIn:=xlValues, _
LookAt:=xlWhole, SearchDirection:=xlNext, MatchCase:=False)
If ChildDOBColumn Is Nothing Then Exit Sub
End With
'Get the range of Adult Household IDs. The code will check each ID.
Dim AdultHouseHolds As Range
With Adult
Set AdultHouseHolds = .Range(AdultHouseholdID.Offset(1), .Cells(.Rows.Count, AdultHouseholdID.Column).End(xlUp))
End With
Dim HouseHold As Range
Dim FirstAddress As String
Dim DOBOffset As Long
Dim ChildDOB As Range
'Look at each Adult Household in turn.
For Each HouseHold In AdultHouseHolds
With Children.Columns(ChildHouseholdID.Column)
'Find the first DOB with corresponding Household ID.
Set ChildDOB = .Find(What:=HouseHold.Value, After:=.Cells(1), LookIn:=xlValues, _
LookAt:=xlWhole, SearchDirection:=xlNext)
If Not ChildDOB Is Nothing Then
'Remember the address - need to check for when FIND loops back around.
FirstAddress = ChildDOB.Address
DOBOffset = 1
Do
'Place the header - the Offset is reset for each Household ID.
Adult.Cells(1, AdultLastColumn.Column + DOBOffset) = "DOB" & DOBOffset
'Copy the Child DOB to the Adult sheet.
Children.Cells(ChildDOB.Row, ChildDOBColumn.Column).Copy _
Destination:=Adult.Cells(HouseHold.Row, AdultLastColumn.Column + DOBOffset)
DOBOffset = DOBOffset + 1
'Find the next value.
Set ChildDOB = .FindNext(ChildDOB)
Loop While ChildDOB.Address <> FirstAddress 'Keep going til it gets back to the first address.
End If
End With
Next HouseHold
End Sub

Answer 3

You're on the right lines.
What you really want your code to do is like this:
For each Child row (search by ID)
Find Matching Adult ID/s (by row)
Add that Child's DOB to the end of the relevant row.
(NB that I'm assuming the DOBs get put at the end of the row, rather than you inserting a dynamic amount of columns in the middle.)
Anyway, in code that would translate roughly to;
Dim LastCol As Integer, AdIDCol As Integer, ChIDcol As Integer, ChDOBCol as Integer
Dim shtA As Worksheet, shtC As Worksheet
Set shtA = ActiveWorkbook.Sheets("Adults")
Set shtC = ActiveWorkbook.Sheets("Children")
LastCol = ShtA.UsedRange.Columns.Count 'Children's DOBs will be put after this column.
'Identify relevant Columns in sheets - checking both sheets in one loop.
For a = 1 to Worksheetfunction.Max(LastCol, shtC.UsedRange.Columns.Count) 'This ensures that all of both sheets will be checked
If LCase(shtA.Cells(1,a).Value) = "household id" Then
AdIDCol = a
End If
If LCase(shtC.Cells(1,a).Value) = "household id" Then
ChIDCol = a
ElseIf LCase(shtC.Cells(1,a).Value) = "dob" Then
ChDOBCol = a
End If
Next a
'Now some nested loops to match children with adults
Dim AdultsFound as Integer 'this will be handy to speed up the loop
'First loop checks through children
For x = 2 to ShtC.UsedRange.Rows.Count
'Second loop checks through Adults
For y = 2 to ShtA.UsedRange.Rows.Count
If ShtC.Cells(x, ChIDCol).Value = ShtA.Cells(y, AdIDCol) Then
AdultsFound = AdultsFound + 1
'Third Loop checks to find what empty cell to copy the DOB into
z = Lastcol
Do While ShtA.Cells(y, z) <> ""
z = z+1 'moves to next column along
Loop
'Once found an empty cell in that row, copy the DOB to it
ShtC.Range(Cells(x, ChDOBCol), Cells(x, ChDOBCol)).Copy ShtA.Range(Cells(y,z), Cells(y,z))
End If
'If there are no more relevant adults in the sheet then stop searching for any more...
If AdultsFound = WorksheetFunction.Countif(ShtA.Cells(1, AdIDCol).EntireColumn, shtC.Cells(x, ChIDCol)) Then Exit For
Next y
Next x
Hope that helps?

Answer 4

Change the last lines of your code to something like this: (untested, but it should give you the idea)
Dim maxDOBColOffset As Long
For z = 2 To lastDRow
Dim DOBColOffset As Long
DOBColOffset = 1
For zz = 2 To lastSRow
If shtA.Cells(z, hid1).Value = shtC.Cells(zz, hid).Value Then
shtA.Cells(z, lastCol1 + DOBColOffset).Value = shtC.Cells(zz, dob).Value
DOBColOffset = DOBColOffset + 1
If maxDOBColOffset < DOBColOffsetThen
shtA.Cells(1, lastCol1 + DOBColOffset).Value = "Child DOB" & DOBColOffset
maxDOBColOffset = DOBColOffsetThen
End If
End If
Next zz
Next z