AW: Aus Excel in Word drucken
05.03.2016 01:51:18
Rolf.dW
Hallo Matthias,
es ist, es ist - aber nicht Gans so einfach, wie der reichste Mann der Welt uns versucht, vorzugaukeln.
Anbei ein Beispiel-Makro für den Ausdruck eines Mitgliederverzeichnisses. Die Daten befinden sich in einer excelDatei, die in eine wordDatei übernommen und anschließend als Broschüre im Format DIN A6 druckreif zur Verfügung gestellt werden. Vielleicht hilft's dir bei deiner Problemlösung etwas weiter.
Gruß, Rolf
Option Explicit
Function WordOffen() As Boolean
Dim wordApp As Word.Application
'Prüft, ob Word bereits aktiviert ist
On Error Resume Next
Set wordApp = GetObject(, "Word.Application")
If Err.Number = 0 Then
WordOffen = True
Else
WordOffen = False
End If
End Function
Sub MitgliederverzeichnisErstellen()
Dim HOME As String, m As String, pfad As String
Dim wahl As Long, i As Long
Dim wsh As Worksheet
Dim WordObj As Object
'Prüft, ob überhaupt Datensätze ausgewählt wurden
HOME = Range("SerBrfHOME").Address
BlattschutzNein 'Sub-Routine
For i = Range(HOME).Row To cells.SpecialCells(xlLastCell).Row - 2
If Range("B" & i).Value = "x" Then
wahl = 1
Exit For
End If
Next i
If wahl 1 Then
MsgBox "Es wurden keine Datensätze für den Seriendruck ausgewählt!"
Range(HOME).Select
Unload frmSerDruck
Exit Sub
Else
'Deaktiviert den Blattschutz für alle Arbeitsblätter 'und speichert es erneut
Application.DisplayAlerts = False
For Each wsh In Sheets
wsh.Unprotect
Next wsh
Unload frmSerDruck
' Application.ScreenUpdating = False
Sheets("GebTag").Activate 'Tabelle wird automatisch nach Datum sortiert
Sheets("SerBrfDat").Activate
m = MsgBox _
("Soll das Mitgliederverzeichnis mit der aktuellen Sortierung erstellt werden?" & _
vbLf & _
vbLf & "Bei 'Nein' wird das MVZ nach Namen sortiert erstellt.", vbYesNo + _
vbCritical)
If m = vbNo Then LogDat_SORT_Name 'Sub-Routine
BlattschutzJa 'Sub-Routine
MsgBox _
"Zur Vermeidung von Kompatibilitätsproblemen muss die Datei " & vbLf & _
"'Logendaten.xlsm' jetzt geschlossen und EXCEL vorübergehend beendet werden." & vbLf & _
vbLf & _
"Bitte klicken Sie auf OK und öffnen Sie anschließend die " & vbLf & _
"WORD-Datei 'MVZ_Dsgn.docm'."
'Dokumentenverzeichnis userkonform anpassen
If Application.UserName = "Kar-Heinz Schnickenfittich" Then
pfad = "C:\worddat\MVZ_KHS\"
Else
pfad = ThisWorkbook.Path & "\"
End If
Application.ScreenUpdating = True
'MVZ_Dsgn.docm öffnen
Application.ScreenUpdating = True
ActiveWorkbook.Save
If WordOffen = False Then
Set WordObj = CreateObject("Word.Application")
Else
Set WordObj = GetObject(, "Word.Application")
End If
WordObj.Visible = True
WordObj.Activate
' Documents.Open Filename:=pfad & "MVZ_Dsgn.docm"
End If
Application.Quit
End Sub
Und dann geht's weiter in der wordDatei:
Option Explicit
Sub Document_Open()
'Erstellt ein druckreifes Mitgliederverzeichnis
Dim exlPfad As String, wrdPfad As String, exlDatei As String, wrdDatei As String, m As _
Integer
Dim tb As Integer, abschnitt As Integer, seite As Integer, tabGeb As Integer
Dim z As Long, zMax As Long
Dim exlOffen As Boolean
Dim exlObj As Object, wordObj
'EXCEL-Verzeichnis Userkonform anpassen
If Application.UserName = "Karl-Heinz Schnickenfittich" Then
exlPfad = "C:\exceldat\MVZ\MVZ_KHS\"
wrdPfad = "C:\worddat\MVZ_KHS\"
Else
exlPfad = ThisDocument.Path & "\"
wrdPfad = ThisDocument.Path & "\"
End If
exlDatei = "Riegedaten.xlsm"
wrdDatei = "MVZ_Ctlg.docx"
'Empfängerliste (Riegedaten.xlsm, Tabelle: EmpfListe) auswählen
Application.ScreenUpdating = True
ActiveDocument.MailMerge.OpenDataSource Name:=exlPfad & exlDatei _
, SQLStatement:="SELECT * FROM `SerBrfDat$` WHERE `Aus-wahl` = 'x'"
'Etiketten erstellen
With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
End With
'leere Etiketten entfernen
tb = ActiveDocument.Tables.Count
With ActiveDocument.Tables(tb)
zMax = .Rows.Count
For z = 2 To zMax Step 13
If Left(.Cell(z, 5), 1) > 9 Or Left(.Cell(z, 5), 1) = 0 Then
.Cell(z - 1, 1).Select
Selection.EndKey Unit:=wdStory, Extend:=wdExtend
Selection.MoveLeft Unit:=wdCharacter, Count:=3, Extend:=wdExtend
Selection.Rows.Delete
Exit For
End If
Next z
End With
'Etiketten-Datei als "MVZ_Ctlg.docx" speichern und schließen
Application.DisplayAlerts = False
ActiveDocument.SaveAs FileName:=wrdPfad & wrdDatei
ActiveDocument.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
'MVZ_Mstr.docm öffnen, das "Filialdokument" (MVZ_Ctlg.docx) einblenden
Documents.Open FileName:=wrdPfad & "MVZ_Mstr.docx"
ActiveDocument.Subdocuments.Expanded = True
ActiveDocument.Fields.Update
'Tabelle (4) "Anschriften" formatieren: Rahmen ausblenden, Tabelle horizontal zentrieren
With ActiveDocument.Tables(4)
.Select
.Borders.InsideLineStyle = wdLineStyleNone
.Borders.OutsideLineStyle = wdLineStyleNone
.Rows.HorizontalPosition = wdTableCenter
End With
'Tabelle(5) "Gruppenleiter" formatieren: zweite Spalte (MatrNr) löschen, _
Zeilenhöhe (Gruppenleiter) auf 4 Zentimeter setzen
With ActiveDocument.Tables(5)
.Select
.Columns(2).Delete
.Rows.HorizontalPosition = wdTableCenter
End With
With Selection.Find
.Text = "Beamte"
.Forward = True
.MatchCase = True
.MatchWholeWord = True
.Execute
End With
Selection.Rows.Height = CentimetersToPoints(4)
'Tabelle "Geburtstage" suchen und formatieren
tabGeb = ActiveDocument.Tables.Count - 2
With ActiveDocument.Tables(tabGeb)
.Select
.Rows.HorizontalPosition = wdTableCenter
.Borders.Enable = False
.Columns(3).Shading.BackgroundPatternColorIndex = wdWhite
End With
'Seitennummern neu formatieren
Selection.HomeKey Unit:=wdStory
seite = 13
For abschnitt = 2 To tb + 1
seite = seite + 1
With ActiveDocument.Sections(abschnitt) _
.Footers(wdHeaderFooterPrimary).PageNumbers
.RestartNumberingAtSection = True
.StartingNumber = seite
End With
Next abschnitt
'Alle WORD-Dateien speichern
' ActiveDocument.Save
ThisDocument.Save
'Excel starten, falls nicht aktiv
Application.ScreenUpdating = False
If exlOffen = False Then
Set exlObj = CreateObject("Excel.Application")
Else
Set exlObj = GetObject(, "exl.Application")
End If
exlObj.Visible = True
On Error Resume Next
Workbooks.Open (exlPfad & exlDatei)
Application.ScreenUpdating = True
Set wordObj = GetObject(, "Word.application")
MsgBox _
"Das Mitgliederverzeichnis wurde in druckreifer Form erstellt." & vbLf & vbLf & _
"EXCEL ist wieder aktiviert und die Datei Riegen.xlsm wurde geöffnet."
Documents("MVZ_Dsgn.docm").Close SaveChanges:=True
End If
End Sub
Function ExcelOffen() As Boolean
Dim exlApp As Excel.Application
Dim exlOffen As Boolean
'Prüft, ob Excel bereits aktiviert ist
On Error Resume Next
Set exlApp = GetObject(, "Excel.Application")
If Err.Number = 0 Then
exlOffen = True
Else
exlOffen = False
End If
End Function