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