Word öffnen, Range formatiert kopieren, nicht als Tabelle...

OptionExplicit
' Konstante für Parameter Umwandlung der Tabelle in Word als Text
' Es gibt:
' Const wdSeparateByDefaultListSeparator = 3
' Const wdSeparateByCommas = 2
' Const wdSeparateByTabs = 1
ConstwdSeparateByParagraphs=0
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 14.07.2014
' Purpose   : Word öffnen, Range formatiert kopieren, nicht als Tabelle...
'--------------------------------------------------------------------------
PublicSubMain()
DimstrBookmarkAsString
DimobjWDAppAsObject
DimobjWDDocAsObject
DimlngCalcAsLong
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
OnErrorGoToFin
' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
WithApplication
' Das Bildschirmaktualisierung wird unterbrochen
.ScreenUpdating=False
' Ereignisroutinen werden deaktiviert
.EnableEvents=False
' Auslesen der momentanen Einstellung für die Berechnung
lngCalc=.Calculation
' Setzen der Berechnung auf "Manuell"
.Calculation=xlCalculationManual
'  Eingabeaufforderungen und Warnmeldungen unterdrücken
.DisplayAlerts=False
EndWith
' Die Wordapplikation sichtbar starten
SetobjWDApp=OffApp("Word")
' Word nicht sichtbar
'Set objApp = OffApp("Word", False)
IfNotobjWDAppIsNothingThen
' Name der Textmarke
strBookmark="Test"
' Ein neues Worddokument erstellen
SetobjWDDoc=objWDApp.Documents.Add
' Diese Zeile ist eigentlich blödsinnig, denn in einem
' neuen Dokument kann keine Textmarke / Bookmark sein
' Aber man sieht, wie auf eine Textmarke geprüft werden kann
' Und wie eine Textmarke hinzugefügt wird
IfNotobjWDDoc.Bookmarks.Exists(strBookmark)=TrueThen
objWDDoc.Bookmarks.AddName:=strBookmark
' Bereich der kopiert werden soll
Tabelle1.Range("A1:A10").Copy
' Aus dem Objektkatalog von Word im VBA-Editor (F2)
' Sub PasteExcelTable(LinkedToExcel As Boolean,
' WordFormatting As Boolean, RTF As Boolean)
objWDDoc.Bookmarks(strBookmark).Range.PasteExcelTableFalse,False,False
' Umwandlen der Tabelle zu Text
objWDDoc.Tables(1).Rows.ConvertToTextSeparator:=wdSeparateByParagraphs,_
NestedTables:=True
EndIf
EndIf
Fin:
' Objektvariablen zurücksetzen
SetobjWDDoc=Nothing
SetobjWDApp=Nothing
' Die Applikation aufwecken
WithApplication
' Bildschirmaktualisierung wieder einschalten
.ScreenUpdating=True
' Ereignisroutinen werden wieder aktiviert
.EnableEvents=True
' Setzen der Berechnung auf den gemerkten Wert
.Calculation=lngCalc
' Eingabeaufforderungen und Warnmeldungen wieder zulassen
.DisplayAlerts=True
' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens
.CutCopyMode=True
EndWith
' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
IfErr.Number<>0ThenMsgBox"Error: "&_
Err.Number&" "&Err.Description
EndSub
'--------------------------------------------------------------------------
' Module    : Module3
' Procedure : OffApp
' Author    : Case (Ralf Stolzenburg)
' Date      : 14.07.2014
' Purpose   : Start application...
'--------------------------------------------------------------------------
PrivateFunctionOffApp(ByValstrAppAsString)AsObject
DimobjAppAsObject
OnErrorResumeNext
SetobjApp=GetObject(,strApp&".Application")
SelectCaseErr.Number
Case429
Err.Clear
SetobjApp=CreateObject(strApp&".Application")
objApp.Visible=True
IfErr.Number>0Then
MsgBoxErr.Number&" "&Err.Description
SetobjApp=Nothing
EndIf
Case0
CaseElse
MsgBoxErr.Number&" "&Err.Description
SetobjApp=Nothing
EndSelect
OnErrorGoTo0
SetOffApp=objApp
SetobjApp=Nothing
EndFunction