Hello everyone,
im using a macro to save automaticly the individual documents of a mail merge (in this case bill's) and save it in a ".docx"-format. I found a code for saving the mail merge documents individually and tried to edit it to attach an excel-table to the bill's.
The macro im using is this(some words are german, i'm sorry for that):
Code:
Sub WORDspeichern()
' set variables
Dim iBrief As Integer, sBrief As String
Dim AppShell As Object
Dim BrowseDir As Variant
Dim Path As String
Dim sPath As Variant
i = 0
' catch any errors
On Error GoTo ErrorHandling
' determine path
Set AppShell = CreateObject("Shell.Application")
Set BrowseDir = AppShell.BrowseForFolder(0, "Speicherort für Serienbriefe auswählen", 0, (strStartPath))
If BrowseDir = "Desktop" Then
Path = sPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
Else
Path = BrowseDir.items().Item().Path
sPath = 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
' hide application for better performance
MsgBox "Rechnungen werden einzeln als WORD-Dateien exportiert!", vbOKOnly + vbInformation
' Application.Visible = False
' create bulkletter and export as pdf
With ActiveDocument.MailMerge
.DataSource.ActiveRecord = 1
Do
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = .ActiveRecord
.LastRecord = .ActiveRecord
sBrief = Path & "2020-" & .DataFields("RECHNUNG").Value & ".doc"
End With
.Execute Pause:=False
Call CreateAnlage(sPath)
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
' error handling
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(sPath As Variant)
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
Call importFromExcel(sPath)
End Sub
Private Function importFromExcel(sPath As Variant)
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
iNr = 20373 + i
strPath = "C:UsersEA.AliciDocumentsTabelleUbersicht2.xlsx"
strPath2 = sPath & "anlagen_excel" & iNr & ".xlsx"
i = i + 1
Set exTab = CreateObject("excel.application")
'exTab.workbooks.Open strPath
exTab.Workbooks.Open strPath2
exTab.Visible = True
'exTab.WorkSheets("Liste Programme und Computer").Activate
exTab.Worksheets("AnlagenTab").Activate
iRow = exTab.Worksheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row
iColumn = exTab.Worksheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Column
exTab.Application.CutCopyMode = False
exTab.Application.CutCopyMode = False
exTab.Application.CutCopyMode = False
exTab.Range(Cells(1, 1), Cells(iRow, iColumn)).Select
exTab.Range(Cells(1, 1), Cells(iRow, iColumn)).Copy
'Textmarker
'Seitenumbruch
'Set einfuegeBereich = ActiveDocument.Range(ActiveDocument.Range.End - 1, ActiveDocument.Range.End)
'einfuegeBereich.Paste
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 Function
This Code is working in the first round perfectly. In the second round (second bill), he throws an error by selecting a range from the excel-table. In the first round as i said, it works fine.
The error in in the function importFromExcel at line "exTab.Range(Cells(1, 1), Cells(iRow, iColumn)).Select".
I would be happy for usefull suggestions. Thanks!