Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1476to1480
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Aus Excel in Word drucken

Aus Excel in Word drucken
04.03.2016 21:58:20
Matthias
Hallo Excelprofis
Ich komme momentan leider nicht weiter und bräuchte eure Hilfe.
Ich habe eine große Exceldatei und diese setzt einen Pfad aus mehreren SVerweisen zusammen. Dieser zusammengesetzte Pfad ist jedoch je nach Sachnummer unterschiedlich und öffnet dann eine von mehreren Word-Datei. Der Pfad befindet sich in Feld A1
Das Ziel ist es nun diese Word-Datei zu öffnen, einen bestimmten Drucker in der geöffneten Datei einzustellen und den Ausdruck dann in bestimmter Anzahl auszudrucken.
Die Anzahl der benötigten Ausdrucke befindet sich wiederum in der Excel Tabelle in A2.
Nach dem Druck soll Word wieder geschlossen und die Exceldatei geöffnet werden.
Ist soetwas überhaupt möglich und wenn ja wie könnte soetwas aussehen?
Vielen Dank schonmal für eure Hilfe
Grüße Matthias

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
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

Anzeige
Aus Excel in Word drucken
05.03.2016 14:13:33
Anton
Hallo Matthias,
so vielleicht:
Sub Aus_Excel_in_Word_drucken()
Dim oWD As Object, oDoc As Object, sAktuellerDrucker As String
If Not CreateObject("Scripting.FileSystemObject").fileexists(Range("A1").Text) Then
MsgBox "Datei " & Range("A1").Text & " nicht gefunden!"
Exit Sub
End If
If CInt(Range("A2")) 
mfg Anton

AW: Aus Excel in Word drucken
05.03.2016 23:55:07
Matthias
Danke euch beiden vielmals!
Anton dein Makro funktioniert absolut perfekt
Grüße Matthias

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige