Sub WORDspeichern()
Dim iBrief As Integer, sBrief As String
Dim AppShell As Object
Dim BrowseDir As Variant
Dim Path As String
On Error GoTo ErrorHandling
Set AppShell = CreateObject("Shell.Application")
Set BrowseDir = AppShell.BrowseForFolder(0, "Speicherort für Serienbriefe auswählen", 0, (strStartPath))
If BrowseDir = "Desktop" Then
Path = CreateObject("WScript.Shell").SpecialFolders("Desktop")
Else
Path = BrowseDir.items().Item().Path
End If
If Path = "" Then GoTo ErrorHandling
Path = Path & "\Rechnungen-" & Format(Now, "dd.mm.yyyy-hh.mm.ss") & "\"
MkDir Path
On Error GoTo ErrorHandling
MsgBox "WATERcontrol Rechnungen werden einzeln als WORD-Dateien exportiert!", vbOKOnly + vbInformation
With ActiveDocument.MailMerge
.DataSource.ActiveRecord = 1
Do
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = .ActiveRecord
.LastRecord = .ActiveRecord
CreateAnlage
sBrief = Path & "2020-" & .DataFields("RECHNUNG").Value & ".doc"
End With
.Execute Pause:=False
If .DataSource.DataFields("RECHNUNG").Value > "" Then
ActiveDocument.SaveAs FileName:=sBrief
End If
ActiveDocument.Close False
If .DataSource.ActiveRecord < .DataSource.RecordCount Then
.DataSource.ActiveRecord = wdNextRecord
Else
Exit Do
End If
Loop
End With
ErrorHandling:
Application.Visible = True
If Err.Number = 76 Then
MsgBox "Der ausgewählte Speicherort ist ungültig", vbOKOnly + vbCritical
ElseIf Err.Number = 5852 Then
MsgBox "Das Dokument ist kein Serienbrief"
ElseIf Err.Number = 4198 Then
MsgBox "Der ausgewählte Speicherort ist ungültig", vbOKOnly + vbCritical
ElseIf Err.Number = 91 Then
MsgBox "Exportieren von Rechnungen abgebrochen", vbOKOnly + vbExclamation
ElseIf Err.Number > 0 Then
MsgBox "Unbekannter Fehler: " & Err.Number & " - Bitte Makro erneut ausführen.", vbOKOnly + vbCritical
Else
MsgBox "Rechnungen erfolgreich exportiert", vbOKOnly + vbInformation
End If
End Sub
Sub CreateAnlage()
Dim rng As Range
Set rng = Selection.Bookmarks("\Page").Range
rng.SetRange rng.End, rng.End
rng.Select
Selection.InsertBreak Type:=wdPageBreak
Selection.Orientation = wdTextOrientationVertical
Set rng = Nothing
importFromExcel
End Sub
Private Sub importFromExcel()
Dim exTab As Object
Dim strPath As String
Dim strPath2 As String
Dim rngPrintArea As Excel.Range
Dim iRow, iColumn As Integer
Dim einfuegeBereich As Range
Dim WordTable As Word.Table
strPath = "C:\Users\EA.Alici\Documents\TabelleUbersicht2.xlsx"
strPath2 = ActiveDocument.Path & "\anlagen_excel\20373.xlsx"
Set exTab = CreateObject("excel.application")
exTab.Workbooks.Open strPath2
exTab.Visible = True
exTab.Worksheets("AnlagenTab").Activate
iRow = exTab.Worksheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row
iColumn = exTab.Worksheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Column
exTab.Range(Cells(1, 1), Cells(iRow, iColumn)).Select
exTab.Range(Cells(1, 1), Cells(iRow, iColumn)).Copy
ActiveDocument.Activate
Selection.Paste
Set WordTable = ActiveDocument.Tables(ActiveDocument.Tables.Count)
ActiveDocument.Tables(ActiveDocument.Tables.Count).Select
With Selection.ParagraphFormat
.LeftIndent = CentimetersToPoints(0.2)
.RightIndent = CentimetersToPoints(0.2)
End With
WordTable.AutoFitBehavior (wdAutoFitWindow)
exTab.Application.DisplayAlerts = False
exTab.Workbooks.Close
End Sub