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

Einen Range (z. B. A1:A10) nach Word kopieren. Schriftformate unverändert übernehmen. Es darf aber nicht als Tabelle eingefügt werden bzw. muss als Text umgewandelt werden.

A range (eg A1:A10) copy to Word. Font formats take over unchanged. But it must not be inserted as a table or must be converted as text.

Hier noch eine Beispieldatei / Here's a sample file:
Word öffnen, Range formatiert kopieren, nicht als Tabelle...[ZIP 20 KB]

Option Explicit
' Konstante für Parameter Umwandlung der Tabelle in Word als Text
' Es gibt:
' Const wdSeparateByDefaultListSeparator = 3
' Const wdSeparateByCommas = 2
' Const wdSeparateByTabs = 1
Const wdSeparateByParagraphs = 0
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 14.07.2014
' Purpose   : Word öffnen, Range formatiert kopieren, nicht als Tabelle...
'--------------------------------------------------------------------------
Public Sub Main()
    Dim strBookmark As String
    Dim objWDApp As Object
    Dim objWDDoc As Object
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
    With Application
        ' 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
    End With
    ' Die Wordapplikation sichtbar starten
    Set objWDApp = OffApp("Word")
    ' Word nicht sichtbar
    'Set objApp = OffApp("Word", False)
    If Not objWDApp Is Nothing Then
        ' Name der Textmarke
        strBookmark = "Test"
        ' Ein neues Worddokument erstellen
        Set objWDDoc = 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
        If Not objWDDoc.Bookmarks.Exists(strBookmark) = True Then
            objWDDoc.Bookmarks.Add Name:=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.PasteExcelTable False, False, False
            ' Umwandlen der Tabelle zu Text
            objWDDoc.Tables(1).Rows.ConvertToText Separator:=wdSeparateByParagraphs, _
                NestedTables:=True
        End If
    End If
Fin:
    ' Objektvariablen zurücksetzen
    Set objWDDoc = Nothing
    Set objWDApp = Nothing
    ' Die Applikation aufwecken
    With Application
        ' 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
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'--------------------------------------------------------------------------
' Module    : Module3
' Procedure : OffApp
' Author    : Case (Ralf Stolzenburg)
' Date      : 14.07.2014
' Purpose   : Start application...
'--------------------------------------------------------------------------
Private Function OffApp(ByVal strApp As String) As Object
    Dim objApp As Object
    On Error Resume Next
    Set objApp = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objApp = CreateObject(strApp & ".Application")
            objApp.Visible = True
            If Err.Number > 0 Then
                MsgBox Err.Number & " " & Err.Description
                Set objApp = Nothing
            End If
        Case 0
        Case Else
            MsgBox Err.Number & " " & Err.Description
            Set objApp = Nothing
    End Select
    On Error GoTo 0
    Set OffApp = objApp
    Set objApp = Nothing
End Function

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...