Erfolglose Fehlersuche

Sub aufteilen()
Dim lngZ, lngLZ, lngAktZeile As Long
' lngZ = ZeilenNr, lngAktZeile = Aktuelle ZeilenNr
Dim intAnzahl, ints, intAnzahlTB, intAnzahlSpalten As Integer
' intAnzahl =      , ints =   intAnzahlTB = AnzahlTabellenblätter
' intAnzahlspalten
Dim strAktBlatt, strName As String
' strAktBlatt = Blattname, strName =
Dim objNeuBlatt As Worksheet
' Objekt Neues Blatt
'Löschen der Tabellen 2 bis n falls nötig
If Sheets.Count > 1 Then 'falls mehr als 1 Tabelle vorhanden
Application.DisplayAlerts = False ' Meldung ausschalten
For intAnzahlTB = Sheets.Count To 2 Step -1
Sheets(intAnzahlTB).Delete
Next intAnzahlTB
Application.DisplayAlerts = True
End If
strAktBlatt = ActiveSheet.Name
'Name der Originaltabelle
lngLZ = Cells(Rows.Count, 3).End(xlUp).Row
'ZeilenNr der letzten belegten Zeile in Spalte C
For lngZ = 2 To lngLZ    'von 2 bis zur letzten Zeile
If Cells(lngZ, 3)  "" Then
intAnzahl = Application.WorksheetFunction.CountIf _
(Range("C" & lngZ + 1 & ":C" & lngLZ), Range("C" & lngZ))
' zählt Anzahl Datensätze je Vertreter
If intAnzahl = 0 Then
Set objNeuBlatt = Worksheets.Add(after:=Sheets(Sheets.Count))
'ein Neues Blatt wird eingefügt
objNeuBlatt.Name = Sheets(strAktBlatt).Cells(lngZ, 3)
' mit dem Blattname des Vertreters
For ints = 1 To Sheets(strAktBlatt).Cells(1, Columns.Count).End(xlToLeft).Column
'von 1 bis letzte Spalte des Originals
objNeuBlatt.Cells(1, ints) = Sheets(strAktBlatt).Cells(1, ints)
'übertragen der Überschriften in die neue Tabelle
Next ints
End If
End If
Next lngZ
'________________________________________________________________
intAnzahlSpalten = Sheets(strAktBlatt).Cells(1, Columns.Count).End(xlToLeft).Column
For lngZ = 2 To lngLZ
'von 2 bis letzte ZeilenNr
strName = Sheets(strAktBlatt).Cells(lngZ, 3)
lngAktZeile = Sheets(strName).Cells(Rows.Count, 3).End(xlUp).Row + 1
Sheets(strName).Range(Sheets(strName).Cells(lngAktZeile, 1), Sheets(strName).Cells(lngAktZeile,  _
intAnzahlSpalten)).Value = _
Sheets(strAktBlatt).Range(Sheets(strAktBlatt).Cells(lngZ, 1), Sheets(strAktBlatt).Cells(lngZ,  _
intAnzahlSpalten)).Value
Next lngZ
Sheets(strAktBlatt).Activate
Cells(1, 1).Select
End Sub