AW: Excel Daten in ein Word einfügen
28.01.2020 09:27:24
UweD
Hallo
hier mit Abfrage der Zeilennummern
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", "Artikel", "Menge", "Bauteil", "Hersteller", _
"Zeugnis", "Werkstoff", "Charge", "Probe", "Stempelcode")
'*** anpassen
WPfad = "G:\avor\Sc\Projekte\0_Umstempelbescheinigung automatisch"
WDatei = "USBVorlage.dotx"
Set TB = ThisWorkbook.Sheets("Tabelle1")
'*** anpassen Ende
ZeileSuch = InputBox("Zeile in der die Suchwerte stehen", "Eingabe Zeilennummer", 5) 'Zeile in der die Suchworte stehen
If Not ZeileSuch > 0 Then
MsgBox "Ungültige Zeilennummer"
Exit Sub
End If
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 = WDatei & "_" & Format(Date, "YYYYMMDD") & ".docx"
'*** Worddatei mit neuem Namen speichern
.SaveAs (WPfad & WNeuNam)
End With
'*** Word schließen
'objWDApp.Quit 'bei Bedarf
End Sub
LG UweD
