Hallo alle Zusammen,

ich habe hier ein Makro, das leider nicht so funktioniert, wie ich es mir wünsche. 

Ich habe ein Makro, mit dem ich Serienbriefe erstellen kann. Das funktioniert auch. Code füge ich noch ein.

Dann habe ich ein Makro, mit dem ich erfolgreich eine Tabelle aus einer externen Excel-Tabelle auf eine zweite Seite importieren kann. Funktioniert auch.

Jetzt versuche ich, beides zu kombinieren. Er fügt die Tabelle erfolgreich ein, zerschießt jedoch die eigentliche Rechnung, welche aus dem Serienbrief erstellt wird.

Hier der Code:

Sub WORDspeichern()
    ' set variables
    Dim iBrief As Integer, sBrief As String
    Dim AppShell As Object
    Dim BrowseDir As Variant
    Dim Path As String
   
    ' 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 = 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
       
    ' hide application for better performance
    MsgBox "WATERcontrol 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
                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
   
    ' 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()
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 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.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 Sub

Ich bin echt kurz vor'm Ziel, das aktuelle Problem jedoch zerbricht mir echt meinen Kopf. Ich hoffe ihr könnt mir helfen.

Grüße,

Eyyub