Hallo zusammen,

Bei meinem Makro bekommen ich immer wieder Laufzeitfehler und geht nicht mehr weiter. Wer kann mir bitte weiter helfen.

Ich habe ein Wartungtool in dem ich "erstellen" tätige werden einige Daten ausgeblendet und einige ausgeblendet. Sobald ich es starte kommt Fehlermeldung :
Laufzeitfehler 13 Typen unverträglich.
Und genau an dieser Stelle " ' Dateinamen generieren:
dnam = "IH-Auftrag_" + Left(wek, 4) + "_" + mon + Trim(Str(jah)) + "_" + Trim(Str(anr)) bleibt stehen.
Einzutragen sind folgenden Daten z.B.:
Monat-->Februar
Jahr-->2023
Region--> Nord-West
Werk-->D4C9 Aachen
Auftragsnummer--> 400000000D4C9
Dann --> "erstellen"


Makro sieht so aus:

Sub ausführen()
Application.DisplayAlerts = False
Dim FSO As New FileSystemObject
Dim ordnerO As Folder
Dim basisOrdnerO As Folder

z1 = 0: weja = 0
loesch
mon = Cells(1, 19)
jah = Cells(1, 20)
wek = Cells(1, 22)
anr = Cells(1, 23)
afn = Cells(1, 18)
pfa = Cells(6, 16)
If mon = "" Then pruef ("G13"): Exit Sub
If jah = "" Then pruef ("I13"): Exit Sub
If wek = "" Then pruef ("G15"): Exit Sub
If anr = "" Then pruef ("G17"): Exit Sub
If afn = "" Then pruef ("G19"): Exit Sub
zeitr
Range("G13").Select
Application.Worksheets("Werke").Visible = True
Sheets("Werke").Select

For x = 3 To werkmax + 1
pwek = Cells(x, 1)
If wek = pwek Then
weja = 1
For y = 2 To aufmax + 1
auf = Cells(x, y)
aufnam = Cells(1, y)
aufzw = Cells(2, y)
If auf = "x" And aufnam > "" Then
z1 = z1 + 1
auftr(z1) = aufnam
aufzeil(z1) = aufzw
End If
Next y
End If
Next x

If z1 = 0 Then
MsgBox ("Bitte das Werk erst einrichten !")
For x = 3 To werkmax + 1
zell = "A" + Trim(Str(x))
Range(zell).Select
pwek = Cells(x, 1)
If wek = pwek Then Exit Sub
Next x
Exit Sub
End If

Application.Worksheets("Werke").Visible = False

Application.Worksheets("Deckblatt").Visible = True
Sheets("Deckblatt").Select
ActiveSheet.Unprotect (pwort)
'Rows("16:658").Select
Rows("16:658").Select
Selection.EntireRow.Hidden = True

For x = 1 To z1
Rows(aufzeil(x)).Select
Selection.EntireRow.Hidden = False
Next x

Range("A1").Select
ActiveSheet.Protect Password:=pwort, DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.Worksheets("Deckblatt").Visible = False

Application.Worksheets("W.-Listen").Visible = True
Sheets("W.-Listen").Select
ActiveSheet.Unprotect (pwort)

Rows("16:658").Select
Selection.EntireRow.Hidden = True

For x = 1 To z1
Rows(aufzeil(x)).Select
Selection.EntireRow.Hidden = False
Next x

Range("A1").Select
ActiveSheet.Protect Password:=pwort, DrawingObjects:=True, Contents:=True, Scenarios:=True

Sheets("Uebersicht").Select
ActiveSheet.Unprotect (pwort)
Range("G13,I13,G15:I15,G17:I17,G19:I19").Select
Selection.Locked = True
Selection.FormulaHidden = False

' Dateinamen generieren:
dnam = "IH-Auftrag_" + Left(wek, 4) + "_" + mon + Trim(Str(jah)) + "_" + Trim(Str(anr))

ActiveSheet.Protect Password:=pwort, DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.Worksheets("Uebersicht").Visible = False

If pfa > "" Then
On Error Resume Next
Set ordnerO = FSO.GetFolder(pfa)
On Error GoTo 0
If ordnerO Is Nothing Then
Set basisOrdnerO = FSO.GetFolder("C:\")
Set ordnerO = basisOrdnerO.SubFolders.Add("WL")
Set ordnerO = Nothing
Set basisOrdnerO = Nothing
MsgBox "Der Ordner " & pfa & " wurde neu angelegt!", vbOKOnly + vbExclamation, "Hinweis"
End If

spnam = pfa + "\" + dnam

ActiveWorkbook.SaveAs Filename:=spnam, FileFormat:=xlOpenXMLWorkbook

'ActiveWorkbook.SaveAs Filename:=spnam '_
', FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
'ReadOnlyRecommended:=False, CreateBackup:=False
MsgBox ("Die Datei für den laufenden Monat" + Chr(13) + "wurde in dem Ordner:" + Chr(13) + pfa + Chr(13) + "mit dem Dateinamen gespeichert." + Chr(13) + dnam)
Else
MsgBox ("Bitte Speichern Sie die Datei über (Speichern unter)" + Chr(13) + "mit einem neuen Dateinamen ab. Dateiname:" + Chr(13) + dnam)
End If
Set FSO = Nothing
Application.DisplayAlerts = True
End Sub

Sub zeitr()
ActiveSheet.Unprotect (pwort)
zeit1 = Cells(1, 19)
zeit2 = Trim(Str(Cells(1, 20)))
Cells(1, 21) = zeit1 + " / " + zeit2
ActiveSheet.Protect Password:=pwort, DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub

Sub pruef(zell)
Range(zell).Select
MsgBox ("Bitte prüfen Sie Ihre Eingabe !")
End Sub

Sub loesch()
For x = 1 To aufmax
auftr(x) = ""
aufzeil(x) = ""
Next x
End Sub


Wer kann mich hierbei unterstützen.

Im Voraus vielen Dank