Populate dynamic columns

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

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?

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