Makro
30.10.2019 09:51:18
Al
ich habe eine excel Datei mit Makros, die ich nicht alles selber geschrieben habe. Nun will ich dass die Makro nicht auf dem Laufwerk "D" einen Ordner erstellt und die Datei da speichert, sondern das ganze soll auf dem Laufwerk "C" erstellt und gespeichert werden. Ich habe "FSO.GetFolder("D:\")" auf "C" umschrieben und legt den Ordner auch auf dem Laufwerk "C" aber der Ordner wird nicht gespeichert und kommt die folgende Fehlermeldung:
Laufzeitfehler 1004
Microsoft Excel kann auf die Datei D:\Wartungslisten\F0217A00 nicht zugreifen. Dies kann mehrere Gründe haben:
-Der Name des Dokuments oder der Pfad ist nicht vorhanden
usw.
Welche Änderungen sollte ich vornehmen, damit es ohne Fehlermeldung auf dem Laufwerk "C" speichenrn kann.
Vielen Dank
So sieht die es 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:614").Select
Rows("16:648").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:648").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").Select
'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))
'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("Wartungslisten")
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