Sub sammeln()
Dim fd, Pfad, Dateiname, lr
Dim Suchstring As String
Dim Bitch As Range
Dim Businessclass As Range
Dim Contactus As Range
Dim C As Variant
Dim wkb As Workbook
Dim lNextrow As Long

   Set wkb = ActiveWorkbook
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
If fd.Show() = True Then
    Pfad = fd.SelectedItems(1) & "\"
    Dateiname = Dir(Pfad & "*.xls")
    Do While Dateiname <> ""
     With Workbooks.Open(Pfad & Dateiname, , True)
Set Bitch = Cells.Find(What:="How you can find us", After:=ActiveCell, LookIn:= _
        xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False)
Set Businessclass = Cells.Find(What:="Business Classification", After:=ActiveCell, LookIn:= _
        xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False)
Set Contactus = Cells.Find(What:="Contact us", After:=ActiveCell, LookIn:= _
        xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False)
        Bitch.Offset(2, 0).Select
        Selection.Copy
        lNextrow = wkb.Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1
        Windows("Book1.xlsm").Activate
        wkb.Worksheets(1).Cells(lNextrow, 1).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
        Windows(2).Activate
        Businessclass.Offset(1, 0).Select
        Selection.Copy
        Windows("Book1.xlsm").Activate
        wkb.Worksheets(1).Cells(lNextrow, 2).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
                
        Bitch.Offset(14, 0).Select
        Selection.Copy
        Windows("Book1.xlsm").Activate
        wkb.Worksheets(1).Cells(lNextrow, 2).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    If Contactus.Offset(5, 0).Value <> "" Then
        Bitch.Offset(5, 0).Select
        Selection.Copy
        Windows("Book1.xlsm").Activate
        wkb.Worksheets(1).Cells(lNextrow, 2).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Else
        
        Bitch.Offset(13, 0).Select
        Selection.Copy
        Windows("Book1.xlsm").Activate
        wkb.Worksheets(1).Cells(lNextrow, 2).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        End If
        
      .Close False
     End With
     Dateiname = Dir()
    Loop
End If
End Sub

Leider geht dann nur einmal und dann kommt Run-Time error 91:

        Businessclass.Offset(1, 0).Select

Kann mir jemand sagen warum?