AW: Von exceltabelle in word per steuerelement temarker
22.04.2024 18:49:51
JoWE
Ritchi,
schau Dir das an:
und die Speicherplatzumgebung (Pfad und Dateien, wobei die Arbeitsmappe nicht unbedingt 'Ritchi_5.xlsm' heißen muss):
und noch der Makro-Code für das gezeigte Konstrukt:
Option Explicit
Private Sub Suchfeld_Click()
'einige Variablen und Objekte definiern
Dim Az As String 'Aktenzeichen
Dim zeNr As Long 'Zeilennummer
Dim ws As Worksheet 'die Excel-Tabelle mit den Daten
Dim myPath As String 'Der Pfad der Word-Vorlagendateien
Dim Importdatei As String 'Die zu nutzende Word-Vorlagendatei
'der Pfad zu den Word-Vorlagendateienwird wird definiert
myPath = "C:\Users\Rahmeln\Desktop\Jugendschutz78\"
' Word-Application wird initialisiert mit 'Late Binding'
' daher ist kein Verweis mehr erforderlich
Dim wdApp As Object
Dim wdDoc As Object
'die Word-Textmarken und -Textmarken Ranges initialisieren
Dim objBkm As Object
Dim rngBkm As Object
' den Ablauf verzögernde Events abschalten
Application.ScreenUpdating = False
Application.EnableEvents = False
' die Excel-Tabelle 'Tabelle1' wird zum Objekt 'ws' erhoben
Set ws = ThisWorkbook.Sheets("Wild")
' Aktenzeichen und die entsprechende Zeilennummer anhand der
' angeklickten Zeile in der DropDown-Liste in die Variablen 'Az' und 'zeNr' schreiben
Az = Me.Suchfeld.List(Me.Suchfeld.ListIndex)
zeNr = Me.Suchfeld.ListIndex + 5
' definieren des zu nutzenden Word-Dokumentes,
Importdatei = myPath & ws.Cells(zeNr, 2)
'es ginge aber auch so wenn Du lieber 'A' oder 'B' benutzen möchtest:
'If UCase(ws.Cells(zeNr, 2)) = "A" Then Importdatei = myPath & "Test1.docx"
'If UCase(ws.Cells(zeNr, 2)) = "B" Then Importdatei = myPath & "Test2.docx"
' die Auswahl im Dropdown ist jetzt nicht mehr erforderlich, also aufheben
Me.Suchfeld.ListIndex = -1
' Word starten
Set wdApp = CreateObject("Word.Application")
' und sichtbar machen
wdApp.Visible = True
'die ausgewählte Word-Datei öffnen
On Error GoTo Fehler_FileAuswahl
Set wdDoc = wdApp.Documents.Open(Importdatei)
' Daten aus dem Objekt 'ws' in das Word-Dokument einfügen
' dabei werden die Textmarken zerstört, besetzt und sofort neu mit Inhalt gesetzt
With wdDoc
Set objBkm = .Bookmarks("Aktenzeichen")
Set rngBkm = objBkm.Range
rngBkm.Text = ws.Cells(zeNr, 1).Value
Set objBkm = .Bookmarks("Datum")
Set rngBkm = objBkm.Range
rngBkm.Text = Format(ws.Cells(zeNr, 3), "DD.MM.YYYY")
Set objBkm = .Bookmarks("Uhrzeit")
Set rngBkm = objBkm.Range
rngBkm.Text = Format(ws.Cells(zeNr, 4), "hh:mm")
Set objBkm = .Bookmarks("Ort")
Set rngBkm = objBkm.Range
rngBkm.Text = ws.Cells(zeNr, 5)
Set objBkm = .Bookmarks("Vorname")
Set rngBkm = objBkm.Range
rngBkm.Text = ws.Cells(zeNr, 7)
Set objBkm = .Bookmarks("Name")
Set rngBkm = objBkm.Range
rngBkm.Text = ws.Cells(zeNr, 8)
Set objBkm = .Bookmarks("Geburtsdatum")
Set rngBkm = objBkm.Range
rngBkm.Text = Format(ws.Cells(zeNr, 9), "DD.MM.YYYY")
Set objBkm = .Bookmarks("Adresse")
Set rngBkm = objBkm.Range
rngBkm.Text = ws.Cells(zeNr, 10)
Set objBkm = .Bookmarks("Postleitzahl")
Set rngBkm = objBkm.Range
rngBkm.Text = ws.Cells(zeNr, 11)
Set objBkm = .Bookmarks("Stadt")
Set rngBkm = objBkm.Range
rngBkm.Text = ws.Cells(zeNr, 12)
Set objBkm = .Bookmarks("Konsummittel")
Set rngBkm = objBkm.Range
rngBkm.Text = ws.Cells(zeNr, 13)
' Hier weitere Datenfelder entsprechend der Spalten in Excel einfügen
End With
' Word in den Vordergund holen
wdApp.Activate
' die mit 'Set" definierten Objekte aus dem Speicher löschen
Set wdDoc = Nothing
Set wdApp = Nothing
' die für den normalen Ablauf deaktivierten Events wieder aktivieren
Application.ScreenUpdating = True
Application.EnableEvents = True
' Cursor auf A1 setzen
Range("A1").Select
' hier ist bei fehlerfreiem Prozess-Verlauf Makro-Ende
Exit Sub
' hier beginnt bei einer Fehlersituation die Fehlerbehandlung
Fehler_FileAuswahl:
MsgBox "Sie haben keine Word-Vorlagendatei ausgewählt!" & vbCr & _
"Der Prozess kann neu gestartet werden!", vbCritical + vbOKOnly
' die für den normalen Ablauf deaktivierten Events wieder aktivieren
Application.ScreenUpdating = True
Application.EnableEvents = True
' Word beenden
wdApp.Quit
' die mit 'Set" definierten Objekte aus dem Speicher löschen
Set wdDoc = Nothing
Set wdApp = Nothing
' Cursor auf A1 setzen
Range("A1").Select
End Sub
So, nun ist's aber auch wirklich genug, Alles weitere ohne mich, ok?!
Auch Dir eine schöne Woche.
Gruß
Jochen