VBA-Fehlermeldung

Sub SymboleKopieren_Zeile_Abstand_Spalte()
'Symbole in Zeile kopieren, einfügen immer in nächste Spalte
Call SymboleKopieren(AbstandZelle:=2)
End Sub

Sub SymboleKopieren(Optional bolZeile As Boolean = True, _
Optional dblAbstand As Double = 0, _
Optional AbstandZelle As Double = 2)
Dim varAuswahl As Variant
Dim wbkZiel As Workbook, wbkQuelle As Workbook
Dim ZelleZiel As Range, objShape As Shape, objShape2 As Shape
Dim wksZiel As Worksheet, wksQuelle As Worksheet
Dim dblTop As Double, dblLeft As Double
Dim lstrFile As String, liSearch As Integer, liNext As Integer, liCol As Integer
Dim Ziel As String, Quelle As String
Dim sFile As String, sPath As String, Name As String
Dim NameVor As String, Gebiet As String, Land As String
Dim Datum As Date
Dim Preisinfo As String, Marke As String, Bemerkungen As String, Quelle2 As String
Ziel = ActiveWorkbook.Name 'aktuelle Zieldatei
lstrFile = Dir(ThisWorkbook.Path & "\*.xlsm")
Do Until lstrFile = ""
Do Until lstrFile  ThisWorkbook.Name
lstrFile = Dir
Loop
If lstrFile = "" Or Left(lstrFile, 1) = "e" Then GoTo Ende
Workbooks.Open ThisWorkbook.Path & "\" & lstrFile
sPath = ThisWorkbook.Path & "\"
FileNeu = "e_" & lstrFile
ActiveWorkbook.SaveAs sPath & FileNeu
'    Kill sPath & lstrFile
Quelle = ActiveWorkbook.Name
With ActiveWorkbook.Sheets(1)
ArtInfo = Range("B10").Value
If ArtInfo = Produkt Then
GoTo Produkt
Else
GoTo Präsentationen
End If
With ActiveWorkbook.Sheets(1)
Produkt:
NameVor = Range("B2").Value
Gebiet = Range("B3").Value
Land = Range("B4").Value
Datum = Range("B5").Value
Reifenmarke = Range("B12").Value
Profilbezeichnung = Range("B14").Value
Dimension = Range("B15").Value
LISI = Range("B16").Value
DOT = Range("B17").Value
Profiltiefe = Range("B18").Value
FahrzeugHersteller = Range("B21").Value
FahrzeugTyp = Range("B22").Value
Einsatzort = Range("B23").Value
PrivatoderGeschäftlich = Range("B24").Value
Erläuterung = Range("B26").Value
Bemerkungen = Range("B83").Value
Quelle2 = Range("B95").Value
Workbooks(Ziel).Activate
Worksheets(1).Select
Range("E9999").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.Value = NameVor
ActiveCell.Offset(0, 1).Value = Gebiet
ActiveCell.Offset(0, 2).Value = Land
ActiveCell.Offset(0, 3).Value = Datum
ActiveCell.Offset(0, 4).Value = Reifenmarke
ActiveCell.Offset(0, 5).Value = Profilbezeichnung
ActiveCell.Offset(0, 6).Value = Dimension
ActiveCell.Offset(0, 7).Value = LISI
ActiveCell.Offset(0, 8).Value = DOT
ActiveCell.Offset(0, 9).Value = Profiltiefe
ActiveCell.Offset(0, 10).Value = FahrzeugHersteller
ActiveCell.Offset(0, 11).Value = FahrzeugTyp
ActiveCell.Offset(0, 12).Value = Einsatzort
ActiveCell.Offset(0, 13).Value = PrivatoderGeschäftlich
ActiveCell.Offset(0, 14).Value = Erläuterung
ActiveCell.Offset(0, 15).Value = Bemerkungen
ActiveCell.Offset(0, 16).Value = Quelle2
ActiveCell.Offset(0, 17).Range("A1").Select
GoTo weiter
Präsentationen:
NameVor = Range("B2").Value
Gebiet = Range("B3").Value
Land = Range("B4").Value
Datum = Range("B5").Value
Reifenmarke = Range("B12").Value
Profilbezeichnung = Range("B28").Value
Bemerkungen = Range("B83").Value
Quelle2 = Range("B95").Value
Workbooks(Ziel).Activate
Worksheets(2).Select
Range("E9999").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.Value = NameVor
ActiveCell.Offset(0, 1).Value = Gebiet
ActiveCell.Offset(0, 2).Value = Land
ActiveCell.Offset(0, 3).Value = Datum
ActiveCell.Offset(0, 4).Value = Reifenmarke
ActiveCell.Offset(0, 5).Value = Profilbezeichnung
ActiveCell.Offset(0, 6).Value = Bemerkungen
ActiveCell.Offset(0, 7).Value = Quelle2
ActiveCell.Offset(0, 8).Range("A1").Select
weiter:
Set wksZiel = ActiveSheet
Set wbkZiel = ActiveWorkbook
Set ZelleZiel = ActiveCell
'Einfüge-Position für erstes Symbol
dblTop = ZelleZiel.Top + AbstandZelle
dblLeft = ZelleZiel.Left + AbstandZelle
'Datei mit eingebetteten Symbolen auswählen
Workbooks(Quelle).Activate
Set wksQuelle = ActiveSheet
Set wbkQuelle = ActiveWorkbook
Set wksQuelle = wbkQuelle.Sheets(1)
For Each objShape In wksQuelle.Shapes
If objShape.Type = 7 Then 'msoEmbeddedOLEObject
objShape.Copy
wksZiel.Paste
With wksZiel
Set objShape2 = .Shapes(.Shapes.Count)
End With
With objShape2
.Top = dblTop
.Left = dblLeft
'Position des nächsten Symbols
If bolZeile = True Then 'anordnen in Zeile nebeneinander
dblTop = dblTop
If dblAbstand = 0 Then
'nächste Symbol in nächste Spalte rechts vom Symbol
Set ZelleZiel = wksZiel.Cells(ZelleZiel.Row, .BottomRightCell.Offset(0, 1).Column) _
_
dblLeft = ZelleZiel.Left + AbstandZelle
Else
'nächste Symbol mit festem Abstand rechts vom vorherigen Symbol
dblLeft = dblLeft + .Width + dblAbstand
End If
Else 'anordnen in Spalte untereinander
dblLeft = dblLeft
If dblAbstand = 0 Then
Set ZelleZiel = wksZiel.Cells(.BottomRightCell.Offset(1, 0).Row, _
ZelleZiel.Column)
dblTop = ZelleZiel.Top + AbstandZelle
Else
dblTop = dblTop + .Height + dblAbstand
End If
End If
End With
End If
Next
wbkQuelle.Close savechanges:=False
If bolZeile = True Then
If Not objShape2 Is Nothing Then
Set ZelleZiel = wksZiel.Cells(objShape2.BottomRightCell.Row + 1, _
ActiveCell.Column)
End If
Else
If Not objShape2 Is Nothing Then
Set ZelleZiel = wksZiel.Cells(objShape2.BottomRightCell.Offset(1, 0).Row, _
ZelleZiel.Column)
End If
End If
ZelleZiel.Select
'  End If
Beenden:
Set wbkZiel = Nothing: Set wbkQuelle = Nothing
Set ZelleZiel = Nothing: Set objShape = Nothing: Set objShape2 = Nothing
Set wksZiel = Nothing: Set wksQuelle = Nothing
liNext = liNext + 1
lstrFile = Dir
End With
Loop
Ende:
Range("A1").Select
ActiveWorkbook.Save
MsgBox "Datenübertrag beendet"
End Sub