Speichern unter in festgelegtem Pfad
12.02.2020 10:22:30
Mauro
Ich habe vor einiger Zeit mit großer Hilfe aus diesem Forum folgendes Makro erstellt.
Es funktioniert einwandfrei, nur möchte ich jetzt, dass das Word Dokument automatisch in einem bestimmten Pfad abgespeichert wird.
Mit meinem VBA Wissen habe ich nur immer den Namen angepasst, nicht den Pfad festgelegt.
Hier der bestehende Code:
Option Explicit
Sub Textmarken()
Dim objWDApp As Object, objDocx As Object, TB, Z, ArrWord, Bmark As String, SP As Integer
Dim WPfad As String, WDatei As String, WNeuNam As String, ZeileSuch As Integer, ZeileWert _
As Integer
ArrWord = Array("Bescheinigung", "Herkunft", "PLZ", "Nummer", "Rayon", _
"Zeugnis", "Masse", "Idea", "Probe", "Fenster", "QP")
'*** anpassen
WPfad = "G:\Test"
WDatei = "Test123.dotx"
Set TB = ThisWorkbook.Sheets("Tabelle1")
'*** anpassen Ende
ZeileSuch = 5
ZeileWert = InputBox("Zeile in der die Tauschwerte stehen", "Eingabe Zeilennummer", _
ZeileSuch + 1)
If Not ZeileWert > 0 Then
MsgBox "Ungültige Zeilennummer"
Exit Sub
End If
'*** Prüfen, Pfad existiert
WPfad = IIf(Right(WPfad, 1) = "\", WPfad, WPfad & "\") 'pfüfen und setzetn \ am Ende
If Dir(WPfad, vbDirectory) = "" Then
MsgBox "Verzeichnis" & vbLf & vbLf & _
" " & WPfad & vbLf & vbLf & _
"existiert nicht!", vbCritical, "Allgemeine Verwaltungsfehler"
Exit Sub
End If
'*** Prüfen, ob Datei im Pfad existiert
If Dir(WPfad & WDatei) = "" Then
MsgBox "Vorlagedatei " & vbLf & vbLf & _
" " & WDatei & vbLf & vbLf & _
"im Verzeichnis " & vbLf & vbLf & _
" " & WPfad & vbLf & vbLf & _
"nicht gefunden!", vbCritical, "Allgemeine Verwaltungsfehler"
Exit Sub
End If
'*** Word-Anwendung sichtbar starten
Set objWDApp = CreateObject("Word.Application")
objWDApp.Visible = True
'*** neue Datei aus Vorlage generieren
Set objDocx = objWDApp.Documents.Add(WPfad & WDatei)
With objDocx
'*** prüfen, ob Textmarken existieren, dann im Worddokument einfügen/ersetzen
For Each Z In ArrWord
'*** Spaltefinden
If WorksheetFunction.CountIf(TB.Rows(ZeileSuch), Z) > 0 Then
SP = WorksheetFunction.Match(Z, TB.Rows(ZeileSuch), 0)
'*** unzulässige Zeichen tauschen/entfernen
Bmark = Replace(Z, " ", "_")
Bmark = Replace(Bmark, "-", "")
Bmark = Replace(Bmark, "(", "")
Bmark = Replace(Bmark, ")", "")
Bmark = Replace(Bmark, "/", "")
Bmark = Replace(Bmark, "\", "")
If .Bookmarks.Exists(Bmark) Then
.Bookmarks(Bmark).Range.Text = TB.Cells(ZeileWert, SP) '*** lesen Der Werte
End If
End If
Next
'*** Neuen Namen zusammensetzen
WNeuNam = TB.Range("P5") & "_" & TB.Range("P" & ZeileWert) & "_" & TB.Range("Q" & _
ZeileWert) & _
"--" & TB.Range("N" & ZeileWert) & ".docx"
'*** Worddatei mit neuem Namen speichern
.SaveAs (WPfad & WNeuNam)
End With
'*** Word schließen
'objWDApp.Quit 'bei Bedarf
End Sub
Ich habe versucht mit Dim Pfad As String und festgelegtem Pfad = "Titel" unter .SaveAs (Pfad & WNeuNam) den Pfad festzulegen, aber dann ändert es mit nur den Namen der Datei, nicht den speicherort.
Kann mir hier jemand weiterhelfen?
Vielen Dank
Mauro