In diesem Beispiel suche ich nach den Überschriften  "Überschrift 1", "Überschrif 2" etc.

Sobald die Überschrift gefunden ist, kopiere ich sämtliche Zellen in eine neue Tabelle, bis die Zelle in Spalte A leer ist.

Ich hoffe, dass ich dir helfen konnte...

Private Sub btnEins_Click()
    Kopiere 1
End Sub
Private Sub btnZwei_Click()
    Kopiere 2
End Sub

Private Sub Kopiere(vZahl As Long)
    Dim lngZeile As Long, lngZielZeile As Long
    Dim lngSpalte As Long, lngZielSpalte As Long
    Dim oWS As Worksheet
    Dim oRange As Range
    lngZeile = 1
    Do Until Cells(lngZeile, 1) = "Überschrift 1"
        lngZeile = lngZeile + 1
    Loop
    lngZeile = lngZeile + 1
    Set oWS = ActiveWorkbook.Worksheets.Add(, Worksheets(Worksheets.Count))
    lngZielZeile = 2
    
    Do Until Cells(lngZeile, 1) = ""
        lngSpalte = 1
        lngZielSpalte = 1
        Do Until Cells(lngZeile, lngSpalte) = ""
            oWS.Cells(lngZielZeile, lngZielSpalte) = Cells(lngZeile, lngSpalte)
            lngSpalte = lngSpalte + 1
            lngZielSpalte = lngZielSpalte + 1
        Loop
        lngZeile = lngZeile + 1
        lngZielZeile = lngZielZeile + 1
    Loop
    If vZahl = 1 Then
        Do Until Cells(lngZeile, 1) = "Überschrift 2"
            lngZeile = lngZeile + 1
        Loop
    Else
        Do Until Cells(lngZeile, 1) = "Überschrift 3"
            lngZeile = lngZeile + 1
        Loop
    End If
    lngZeile = lngZeile + 1
    Do Until Cells(lngZeile, 1) = ""
        lngSpalte = 1
        lngZielSpalte = 1
        Do Until Cells(lngZeile, lngSpalte) = ""
            oWS.Cells(lngZielZeile, lngZielSpalte) = Cells(lngZeile, lngSpalte)
            lngSpalte = lngSpalte + 1
            lngZielSpalte = lngZielSpalte + 1
        Loop
        lngZeile = lngZeile + 1
        lngZielZeile = lngZielZeile + 1
    Loop
    oWS.Activate
End Sub