VBA Excel Zellinhalte in Word Tabelle einfügen
25.08.2015 12:48:08
Moritz
ich habe folgendes Problem. Ich möchte die Daten eines bestimmten Excel-Datenblatts über einen CommandButton automatisch in eine Word Tabelle einfügen lassen, hierbei ist die Auswahl der Tabellenzellen sowohl in Excel als auch Word wichtig. Dieses Word Doc soll dann zur Abstimmung der jeweiligen Textbausteine versendet werden (Verwendung des erstellten Dokuments) und daraufhin wieder in die ursprüngliche Excel-Datei eingefügt werden, indem die alten Zellinhalte überschrieben werden. Der Export aus Excel heraus, läuft über ein Makro (aus dem Internet zusammengebastelt) , welches automatisch einen Serienbrief generiert. Wenn ich dieses Makro jedoch durchlaufen lasse, löscht es mir das in Word hinterlegte Makro des "Datenimport" (entspricht ja eigentlich auch einem Export), dessen CommandButton jedoch bleibt bestehen. Kann mir hier jemand weiterhelfen?
Das Serienbrief Makro sieht wie folgt aus:
Private Const strDatenQuelle As String = "C:\WorkBox_Vorlagen\Mappe1.xlsx" 'Transfer-Excel- _
Datei Pfad
Private Const strWOrdvorlage As String = "C:\WorkBox_Vorlagen\Archiv_Versuche\Import.dotm" ' _
_
Word-Vorlage Serienbrief Pfad
Sub CommandButton1_Click()
Dim Bereich As Range, wb As Workbook
Z = Cells(Rows.Count, 3).End(xlUp).Row
Set Bereich = Range("A1: P2" & Z & "") 'Bereich mit Serienbrief-Daten
Set wb = Workbooks.Open(Filename:=strDatenQuelle)
' Workbooks.Open Filename:= _
"D:\Time WorkBoxVersuch.xls"
'Datei Speichern und schliessen
wb.Save
wb.Close
Call Serienb
End Sub
Sub Serienb() 'Im Excel VBA-Editor für die Datei mit diesem Makro unter Extras-Verweise _
den Verweis auf die Microsoft Word x.y Object Library aktivieren!!
Dim WinWord, WinDoc As Word.Document, docImport As Word.Document
Dim sFile As String, strCon As String
sFile = strWOrdvorlage
Set WinWord = CreateObject("Word.Application")
With WinWord
.Visible = True
'Vorlagedatei öffnen
Set WinDoc = .Documents.Open(sFile)
With WinDoc
With .MailMerge
'Datenquelle öffnen
.OpenDataSource Name:=strDatenQuelle, _
ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
AddToRecentFiles:=False, PasswordDocument:="", _
PasswordTemplate:="", WritePasswordDocument:="", WritePasswordTemplate:="", _
Revert:=False, Format:=wdOpenFormatAuto, _
Connection:="Provider=Microsoft.Jet.OLEDB.4.0;Password="""";" _
& "User ID=Admin;" _
& "Data Source=" & strDatenQuelle & ";" _
& "Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";" _
& "Jet OLEDB:System database="""";" & "Jet OLEDB:Registry Path="""";" _
& "Jet OLEDB:Database Password="""";" _
& "Jet OLEDB:Engine ", _
SQLStatement:="SELECT * FROM `Tabelle1$`", SQLStatement1:="", _
SubType:=wdMergeSubTypeAccess
'Serienbrief mit allen Daten in neuem Dokument erstellen
.Destination = NewDocument 'wdSendToNewDocument, ohne SendTo funktioniert es _
_
_
strWOrdvorlage
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
Set docImport = WinWord.ActiveDocument
'Datenquelle wieder schliessen
.DataSource.Close
End With
'Vorlagedatei wieder schliessen (entfernt)
docImport.Application.WindowState = wdWindowStateMaximize
End With
Set docImport_Vorlage = Nothing
Set WinWord = Nothing
Set WinDoc = Nothing
End With
End Sub
Was noch gesagt werden muss ist, dass als Datenquelle eine andere, verlinkte Exceldatei herhalten muss bisher, weil ich es nicht hinbekommen habe das aktive Exceldokument als Datenquelle zu verwenden.
Das Word Makro zum "Datenimport" sieht wie folgt aus:
Private Sub CommandButton1_Click()
Dim i As Integer
Dim xlApp As Excel.Application
Dim xlWorkbook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim strPathExcel As String
Dim blnFileExists As Boolean
strPathExcel = "C:\Versuche\Import.xlsm"
'* Excel öffnen
Set xlApp = CreateObject("Excel.Application")
'* Überprüfen ob File existiert
If Dir(strPathExcel) = "" Then '* File existiert nicht
blnFileExists = False
Set xlWorkbook = xlApp.Workbooks.Add
Else '* File existiert
blnFileExists = True
Set xlWorkbook = xlApp.Workbooks.Open(strPathExcel)
End If
'* Applikation "verstecken"
xlApp.Visible = False
Set xlSheet = xlWorkbook.Worksheets(1)
Set xlSheet2 = xlWorkbook.Worksheets(2) 'entsprechendes Tabellenblatt angeben
'*Bestimmte Felder über deren Namen ansprechen
'* und in die gewünschte Zelle setzen
xlSheet2.Cells(2, 1) = ActiveDocument.Tables(1).Cell(2, 1) 'gewünschtes Tabellenblatt, oben _
aus Set die Bezeichnung übernehmen
xlSheet.Cells(2, 2) = ActiveDocument.Tables(1).Cell(2, 2)
xlSheet.Cells(2, 3) = ActiveDocument.Tables(1).Cell(4, 1)
MsgBox "Export abgeschlossen!"
'* Applikation wieder sichtbar machen
xlApp.Visible = True
'* Excel schliessen
Set xlWorkbook = Nothing
Set xlSheet = Nothing
'* Applikation beenden
xlApp.Quit
Set xlApp = Nothing
End Sub
Das Worddokumemt könnte auch als Template abgespeichert werden. Kann hier jemand bei diesem Problem weiterhelfen? Möglicherweise muss man den Export aus Excel heraus nicht über eine Serienbrieffunktion starten, vlt vereinfacht dies das ganze. Vielen Dank schon mal im Voraus! Grüße :)