Select and Copy Range from Active Cell

I've got my language wrong.

I want my code to evaluate each cell in column B, and based on its value, copy the row from D to X and paste on the newly activated worksheet. I'm trying to use Offset, but it's not working.

Sub CrtTms_Click()
Dim Ans As Integer

Ans = MsgBox("Has Each Child Been Assigned A Team?", vbYesNo)

Select Case Ans
Case vbNo
Exit Sub

Case vbYes
Dim TmNmbr As Range
With Sheet1

For Each TmNmbr In Range("B2:B200")

    Range(ActiveCell.Offset(0, 2), ActiveCell.Offset(0, 21)).Select
    Selection.Copy

Select Case TmNmbr.Value

    Case 1

        Sheet2.Activate
        Range("A2").Select
            Do

                If IsEmpty(ActiveCell) = False Then

                ActiveCell.Offset(1, 0).Select
        
                End If

            Loop Until IsEmpty(ActiveCell) = True
            
 ActiveCell.PasteSpecial
 Application.CutCopyMode = False
 

End Select
Next TmNmbr

End With

End Select

End Sub

Perhaps, if I've understood,

Sub CrtTms_Click()
Dim TmNmbr As Range
If MsgBox("Has Each Child Been Assigned A Team?", vbYesNo) = vbNo Then Exit Sub
For Each TmNmbr In Sheet1.Range("B2:B200")
    If TmNmbr.Value = 1 Then
        TmNmbr.Offset(, 2).Resize(, 21).Copy Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Offset(1)
    End If
Next TmNmbr
End Sub

Based on its value...copy D:X... what value are your testing for? Anything?

Without referring to your code, can you just explain verbally what you're macro is supposed to accomplish?

For instance:
"For every cell in B2:B200 that is not blank, copy D:X to another sheet. On the new sheet I want all the data without blanks"

If you post up your sheet with perhaps an example BEFORE/AFTER, we can help more specifically.

It might be an idea to outline the naming convention of your team sheets, using codenames is ok if they follow some logic.

I would simply adapt that already provided

Sub CrtTms_Click()
Dim TmNmbr As Range
If MsgBox("Has Each Child Been Assigned A Team?", vbYesNo) = vbNo Then Exit Sub
For Each TmNmbr In Sheet1.Range("B2:B200")
    If Val(TmNmbr.Value) Then
        Set wsDest = Sheets(1 + TmNmbr.Value)
        TmNmbr.Offset(, 2).Resize(, 21).Copy wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1)
        Set wsDest = Nothing
    End If
Next TmNmbr
End Sub

I should add that in my prior example the sheet selection was based on Index position (ie physical position in file with 1 being leftmost sheet) which may/may not be correct.