Populate dynamic columns

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

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

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 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 4

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?