AW: Bsp-Datei
11.04.2017 08:33:02
Florian
Hi, danke für die schnelle Antwort! Das Coding unten funktioniert nun nicht mehr... zu viel "herumgespielt".
Inhaltlich habe ich gestern noch mal neu angefangen und bin nicht fertig, da eben das Einfügen aus verschiedenen Tabellenblättern nicht funktioniert.
Ich möchte:
- auf allen drei aufgeführten Tabellenblättern sowohl
-- Text einer bestimmten Zelle einfügen
-- einen Bereich als Bild einfügen
-- und eine Tabelle einfügen. Je nach Kunde variiert die Größe der Tabelle. Dies fange ich durch indirekt ab sodass der Namensbereich immer der Tabelle entspricht und eingefügt werden soll. Es sind Pivottabellen aus meist zwei Spalten und einer unterschiedlichen Anzahl an Zeilen.
Mit bestem Dank im Voraus
Viele grüße
Flo
Option Explicit
' Namen der Textmarken im Worddokument
Const strBookmark1 As String = "Kundenadresse"
Const strBookmark2 As String = "Berichtszeitraum_Monat"
Const strBookmark3 As String = "Empfaenger"
Const strBookmark4 As String = "Service_Kunde"
Const strBookmark5 As String = "Betreff"
Const strBookmark6 As String = "Wertetabelle"
Const strBookmark7 As String = "Wertetabelle1"
' Konstante für den Speichern-Unter Dialog in Word
Const wdDialogFileSaveAs = 84
' Wenn Word nicht offen ist wird diese Variable auf True
' gesetzt und Word am Ende wieder geschlossen
' War Word schon offen, belibt es das auch
Dim blnTMP As Boolean
Public Sub Main()
Dim objWordRange As Object
Dim objDocument As Object
Dim objDialog As Object
Dim objApp As Object
Dim strDoc As String
Dim WordObj As Object
On Error GoTo Fin
' Das Worddokument mit Pfad und Name
strDoc = ThisWorkbook.Path & _
Application.PathSeparator & "SLA-Bericht.doc"
' Die Wordapplikation wird mit der Funktion "OffApp" gesucht
' ODER bei Bedarf gestartet
Set objApp = OffApp("Word")
'folgende Codezeile für Word nicht sichtbar
'Set objApp = OffApp("Word", False)
' Wenn die Word der Objektvariablen zugewiesen werden konnte dann...
If Not objApp Is Nothing Then
' Öffne das Worddokument, zugewiesen an die Objektvariable objDocument
Set objDocument = objApp.Documents.Open(Filename:=strDoc)
' With für Schreibfaule :-) Alle Bezüge auf Tabelle1 müssen
' mit einem Punkt beginnen
With ThisWorkbook.Worksheets("Empfaenger Bericht_Anschrift")
' Prüfe, ob die Textmarke vorhanden ist
If objDocument.Bookmarks.Exists(strBookmark1) = True Then
.Range("Kundenadresse").Copy
Set objWordRange = objDocument.Bookmarks(strBookmark1).Range
objWordRange.Paste
End If
' With ThisWorkbook.Worksheets("SLA")
' If objDocument.Bookmarks.Exists(strBookmark2) = True Then
' objDocument.Bookmarks(strBookmark2).Range = .Range("Berichtszeitraum").Text
' End If
' If objDocument.Bookmarks.Exists(strBookmark3) = True Then
' objDocument.Bookmarks(strBookmark3).Range = .Range("Empfaenger").Text
' End If
' End With
With ThisWorkbook.Worksheets("Kunden")
If objDocument.Bookmarks.Exists(strBookmark4) = True Then
objDocument.Bookmarks(strBookmark4).Range = .Range("Service_Kunden").Value
End If
End With
' If objDocument.Bookmarks.Exists(strBookmark5) = True Then
' objDocument.Bookmarks(strBookmark5).Range = .Range("F2").Text
' End If
' Kopiere einen Bereich als Bild an die Textmarke Wertetabelle
' Objektvariable objWordRange leeren
If objDocument.Bookmarks.Exists(strBookmark6) = True Then
.Range("H1:J4").CopyPicture 1, 2
Set objWordRange = objDocument.Bookmarks(strBookmark6).Range
objWordRange.Paste
Set objWordRange = Nothing
End If
' Ameisenrennen um den kopierten Bereich beenden
' und Zwischenspeicher leeren
Application.CutCopyMode = True
' Objektvariable objWordRange leeren
Set objWordRange = Nothing
' Word Speicherdialog aufrufen
Set objDialog = objApp.Dialogs(wdDialogFileSaveAs)
With objDialog
' Pfad vorgeben
.Name = "C:\Temp\"
' Wenn auf Speichern geklickt wurde...
If .Display = -1 Then
objDocument.SaveAs Filename:=.Name
End If
' Dokument schliessen
' objDocument.Close
End With
End With
Else
' Ausgabe, wenn die Objektvariable objApp Nothing ist...
MsgBox "Applikation nicht installiert!"
End If
Fin:
If Not objApp Is Nothing Then
' Word war nicht offen, also...
If blnTMP = True Then
' ... Word schliessen
' objApp.Quit
blnTMP = False
End If
End If
' Objektvariablen leeren
Set objWordRange = Nothing
Set objDocument = Nothing
Set objApp = Nothing
Application.CutCopyMode = True
' Wenn die Fehlernummer NICHT 0 ist, dann gib die Fehlernummer
' und die Fehlerbeschreibung aus
If Err.Number 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String, _
Optional blnVisible As Boolean = True) As Object
Dim objApp As Object
On Error Resume Next
Set objApp = GetObject(, strApp & ".Application")
Select Case Err.Number
Case 429
Err.Clear
Set objApp = CreateObject(strApp & ".Application")
blnTMP = True
If blnVisible = True Then
On Error Resume Next
objApp.Visible = True
Err.Clear
End If
End Select
On Error GoTo 0
Set OffApp = objApp
Set objApp = Nothing
End Function