Tabellen zusammenführen

Sub Zusammenschreiben()
Dim ws As Worksheet
Dim wsTotal As Worksheet
Dim lngLastCol As Long
Dim lngLastRow As Long
Dim rngTotalFound As Range
Dim lngTotalRow As Long
Dim lngCounter As Long
Dim strSearch As String
On Error GoTo Zusammenschreiben_Error
Application.ScreenUpdating = False
Set wsTotal = Sheets("Tabelle6")
For Each ws In Worksheets 'hier komme ich nicht weiter
If ws.Name  wsTotal.Name Then
lngTotalRow = wsTotal.Cells(Rows.Count, "A").End(xlUp).Row + 1
Debug.Print lngTotalRow
With ws
lngLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row + 1
lngLastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
.Range("A2:F" & lngLastRow).Copy Destination:=wsTotal.Range("A" & lngTotalRow)
If lngLastCol > 6 Then
For lngCounter = 7 To lngLastCol
strSearch = ws.Cells(1, lngCounter)
Set rngTotalFound = wsTotal.Rows("1:1").Find( _
what:=strSearch, LookIn:=xlValues, lookat:=xlWhole, _
searchorder:=xlByRows)
If rngTotalFound Is Nothing Then
Set rngTotalFound = wsTotal.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)
rngTotalFound.Value = strSearch
End If
.Range(Cells(2, lngCounter).Address, Cells(lngLastRow, lngCounter).Address).Copy  _
Destination:=wsTotal.Cells(lngTotalRow, rngTotalFound.Column)
Next lngCounter
End If
End With
End If
Next ws
exit_here:
Set rngTotalFound = Nothing
Application.ScreenUpdating = True
On Error GoTo 0
Exit Sub
Zusammenschreiben_Error:
MsgBox "Fehler " & Err.Number & " (" & Err.Description & ") in der Prozedur Zusammenschreiben"
Resume exit_here
End Sub