AW: Makro Programmieren
05.06.2019 17:01:45
UweD
Hi
nach dem gleichen Muster
Option Explicit
Sub WordDatei()
Dim objWDApp As Object, objDocx As Object
Dim WPfad As String, WDatei As String, WNeuNam As String
Dim TB, i As Integer
Set TB = ThisWorkbook.Sheets("Tabelle1")
WPfad = "x:\Temp\"
WDatei = "Liturgieplan.doc"
'*** 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
For i = 11 To 18
'*** prüfen, ob Textmarken existieren, dann im Worddokument einfügen/ersetzen
If .Bookmarks.Exists("F" & i) Then
.Bookmarks("F" & i).Range.Text = Format(DateValue(TB.Cells(i, 6) & "." & TB.Cells(8, 5) & " " & Year(Date)), "DD.MM.")
End If
If .Bookmarks.Exists("G" & i) Then
.Bookmarks("G" & i).Range.Text = TB.Cells(i, 7)
End If
If .Bookmarks.Exists("H" & i) Then
Select Case TB.Cells(i, 8)
Case "ex"
.Bookmarks("H" & i).Range.Text = "extraordinaria"
Case "o"
.Bookmarks("H" & i).Range.Text = "ordinaria"
End Select
End If
If .Bookmarks.Exists("I" & i) Then
.Bookmarks("I" & i).Range.Text = TB.Cells(i, 9) & " Klasse"
End If
If .Bookmarks.Exists("K" & i) Then
.Bookmarks("K" & i).Range.Text = TB.Cells(i, 11)
End If
If .Bookmarks.Exists("M" & i) Then
.Bookmarks("M" & i).Range.Text = TB.Cells(i, 13)
End If
If .Bookmarks.Exists("N" & i) Then
.Bookmarks("N" & i).Range.Text = TB.Cells(i, 14)
End If
If .Bookmarks.Exists("O" & i) Then
.Bookmarks("O" & i).Range.Text = TB.Cells(i, 15)
End If
If .Bookmarks.Exists("P" & i) Then
.Bookmarks("P" & i).Range.Text = TB.Cells(i, 16)
End If
If .Bookmarks.Exists("Q" & i) Then
.Bookmarks("Q" & i).Range.Text = TB.Cells(i, 17)
End If
Next
'*** Neuen Namen zusammensetzen
WNeuNam = Format(Date, "YYYYMMDD") & "_" & WDatei
'*** Worddatei mit neuem Namen speichern
.SaveAs (WPfad & WNeuNam)
End With
'*** Word schließen
'objWDApp.Quit 'bei Bedarf
End Sub
LG UweD
