14.07.2014

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

Formeln auf einer UserForm in einer TextBox darstellen...

Formeln auf einer UserForm in einer TextBox anzeigen. Z. B. "Formula", "FormulaLocal"... und wie muss die Formel in VBA ...