Übergabe von Excel nach Word und und und

Private Sub CommandButton2_Click()
Debug.Print "Start: " & Time
With Windows.Application
.CutCopyMode = False
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim iCounter As Integer
Dim strSaveName As String
Dim strSavePath As String
Dim strTxt As String
Dim strPic As String
Dim strPicPath As String
Dim strPicName As String
Dim strPicWm As String
Dim strPicBmp As String
Dim Shp As Word.Shape
Dim dblLeft As Double
Dim dblTop As Double
Dim blnYesNo As Boolean
'Speicherort für Angebot
strSavePath = ThisWorkbook.Path & "\"
strSaveName = Worksheets("Eingabe").Range("E14")
'Speicherort der Bilddateien
strPicPath = "C:\FHK95\Bilder\"
strPicBmp = ".bmp"
strPicWm = "Shape_Watermark"
'Create Word Application
Set wdApp = CreateObject("Word.Application")
Set wdDoc = wdApp.Documents.Add
'Format Word Document
With wdApp
With .Selection.ParagraphFormat
.LeftIndent = wdApp.CentimetersToPoints(0)
.RightIndent = wdApp.CentimetersToPoints(0)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.Alignment = wdAlignParagraphLeft
.WidowControl = True
.KeepWithNext = False
.KeepTogether = False
.PageBreakBefore = False
.NoLineNumber = False
.Hyphenation = True
.FirstLineIndent = wdApp.CentimetersToPoints(0)
.OutlineLevel = wdOutlineLevelBodyText
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LineUnitBefore = 0
.LineUnitAfter = 0
.MirrorIndents = False
.TextboxTightWrap = wdTightNone
End With
With .ActiveDocument.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientPortrait
.TopMargin = wdApp.CentimetersToPoints(5)
.BottomMargin = wdApp.CentimetersToPoints(2)
.LeftMargin = wdApp.CentimetersToPoints(2)
.RightMargin = wdApp.CentimetersToPoints(1.5)
.Gutter = wdApp.CentimetersToPoints(0)
.HeaderDistance = wdApp.CentimetersToPoints(0)
.FooterDistance = wdApp.CentimetersToPoints(0)
.PageWidth = wdApp.CentimetersToPoints(21)
.PageHeight = wdApp.CentimetersToPoints(29.7)
.FirstPageTray = wdPrinterFormSource
.OtherPagesTray = wdPrinterFormSource
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
End With
'Insert Watermark
strPic = strPicPath & strPicWm & strPicBmp
With .ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Shapes.AddPicture( _
Filename:=strPic, linktofile:=False, savewithdocument:=True)
.Name = "Wolf Briefpapier"
.PictureFormat.Brightness = 0.5
.PictureFormat.Contrast = 0.5
.LockAspectRatio = True
.Height = wdApp.CentimetersToPoints(32)
.Width = wdApp.CentimetersToPoints(20.6)
.WrapFormat.AllowOverlap = True
.WrapFormat.Side = wdWrapNone
.WrapFormat.Type = wdWrapBehind
.RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin
.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
.Left = wdShapeCenter
.Top = wdShapeCenter
End With
End With
'Format Text in Excel
Worksheets("zwischen").Range("A2:Z800").ClearContents
Worksheets("text").Range("A1:Z800").ClearContents
Worksheets("auswert").Range("B2:B500").Copy
Worksheets("zwischen").Range("a2").PasteSpecial Paste:=xlValues, Operation:=xlNone,  _
SkipBlanks:=False, Transpose:=False
Worksheets("zwischen").Range("a1").AutoFilter Field:=1, Criteria1:="0", Operator:=xlAnd
Worksheets("zwischen").Range("A2:A500").Copy
Worksheets("text").Range("A1").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Worksheets("text").Range("A:A").Copy
Debug.Print "Word formatiert, Texte formatieren: " & Time
'WORD VBA
With wdApp
'Insert Text
.Selection.PasteExcelTable False, False, True
Dim tbl As Table
For Each tbl In .ActiveDocument.Tables
tbl.ConvertToText Separator:=wdSeparateByParagraphs
Next tbl
Set tbl = Nothing
'MsgBox Angebot mit Bilder?
If MsgBox("Angebot mit Bildern Ja, oder nein?", vbYesNo) = vbYes Then blnYesNo = True  _
Else blnYesNo = False
'Format Text
For iCounter = 0 To 10
' 0 = (Jump) = xx   -> Absätze
' 1 = (Jump) = Normalbeton
' 2 = (Jump) = Dichtbeton
' 3 = (Jump) = Fundamentplatte
' 4 = (Jump) = Fundamentplatte auf Frostkoffer
' 5 = (Jump) = Datum
' 6 = (Loop) = *    -> FETT
' 7 = (Loop) = ///  -> FETT
' 8 = (Loop) = ###  -> löschen
' 9 = (Loop) = yy   -> Tabs einfügen
'10 = ( ** ) = °°°  -> *If blnYesNo=True then Jump else Loop* Bei Bildern mit zu  _
geringem Textabstand für das Bild mehr Absätze einfügen
If iCounter = 0 Then strTxt = "xx" Else If iCounter = 1 Then strTxt = "ANGEBOT  _
NORMALBETONKELLER" Else If iCounter = 2 Then strTxt = "ANGEBOT DICHTBETONKELLER" _
Else If iCounter = 3 Then strTxt = "ANGEBOT FUNDAMENTPLATTE mit STREIFENFUNDAMENTEN" _
Else If iCounter = 4 Then strTxt = "ANGEBOT FUNDAMENTPLATTE auf FROSTKOFFER" _
Else If iCounter = 5 Then strTxt = "Datum" Else If iCounter = 6 Then strTxt = "*"  _
Else If iCounter = 7 Then strTxt = "///" Else If iCounter = 8 Then strTxt = "###" _
Else If iCounter = 9 Then strTxt = "yy" Else If iCounter = 10 Then strTxt = "°°°"
.Visible = True
If iCounter  With .Selection  0 Then .Execute
End If
End If
If blnYesNo = True Then         '°°° Bildabstände
If iCounter = 10 Then
.Execute Replace:=wdReplaceAll
End If
End If
End With
If iCounter = 1 Or iCounter = 2 Or iCounter = 3 Or iCounter = 4 Then 'Ü _
berschriften Formatierung
.Font.Size = 14
.Font.Bold = wdToggle
.Font.Italic = wdToggle
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.MoveRight unit:=wdCharacter, Count:=1
End If
If iCounter = 5 Then            'Datum einfügen
.InsertDateTime DateTimeFormat:="dd.MM.yyyy", InsertAsField:=False,  _
DateLanguage:=wdGerman, CalendarType:=wdCalendarWestern, InsertAsFullWidth:=False
.MoveLeft unit:=wdCharacter, Count:=10
.ParagraphFormat.Alignment = wdAlignParagraphRight
End If
If iCounter = 6 Then        '* FETT
If .Find.Execute = True Then
.InsertSymbol Font:="CommercialPi BT", CharacterNumber:=-4047,  _
Unicode:=True
.MoveLeft unit:=wdCharacter, Count:=1
.EndKey unit:=wdLine, Extend:=wdExtend
.Font.Bold = wdToggle
If blnYesNo = True Then 'Tab & Indent if PIC
.Paragraphs.TabStops.Add Position:=InchesToPoints(4), Alignment: _
=wdAlignTabRight
.Paragraphs.RightIndent = 165
Else:                   'Tab if no PIC
.Paragraphs.TabStops.Add Position:=InchesToPoints(6.4),  _
Alignment:=wdAlignTabRight
End If
Else: Exit Do
End If
End If
If iCounter = 7 Then        '/// FETT
If .Find.Execute = True Then
.Delete
.EndKey unit:=wdLine, Extend:=wdExtend
.Font.Bold = wdToggle
Else: Exit Do
End If
End If
If iCounter = 8 Then        '### + Leerzeilen entfernen
If .Find.Execute = True Then
.EndKey unit:=wdStory, Extend:=wdExtend
.Delete unit:=wdCharacter, Count:=1
Else: Exit Do
End If
End If
If iCounter = 9 Then        'yy Tabs einfügen
If .Find.Execute = True Then
.Delete
.InsertAfter (vbTab)
Else: Exit Do
End If
End If
If blnYesNo = False Then
If iCounter = 10 Then        '°°° Bildabstände
If .Find.Execute = True Then
.Delete
Else: Exit Do
End If
End If
End If
If iCounter  0 Then
wdApp.ActiveDocument.SaveAs2 Filename:=strSavePath & "AN_" & strSaveName
Else
wdApp.WordBasic.MsgBox "Speichern vom Benutzer abgebrochen!!"
End If
End With
End With
'END WORD VBA
Worksheets("Eingabe").Range("E13").Select
With Windows.Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
Set wdDoc = Nothing
Set wdApp = Nothing
Debug.Print "Ende: " & Time
End Sub