Excel - Word - vertikal verbundene Zellen - Tabelle - Zeile löschen...

Frage: Von einem Exceldokument wird ein bestimmter Bereich nach Word kopiert. Dieser beinhaltet vertikal verbundene Zellen. Das löschen einer Zeile dieser Tabelle mit "Rows(2).Delete" scheitert. Wie geht das?

From an Excel document a particular range is copied to Word. This includes vertically merged cells. Delete a row in this table with "Rows(2).Delete" fails. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
Excel - Word - vertikal verbundene Zellen - Tabelle - Zeile löschen...[XLS 40 KB]

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 28.01.2013 
' Purpose   : Excel to Word with vertically merged cells... 
'-------------------------------------------------------------------------- 
Const wdDeleteCellsEntireRow = 2
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 
            ' Sheet1 ist der Codename eines Tabellenblattes 
            ' in einem englischen Excel 
            ' In deutsch dann Tabelle1 
            Sheet1.Range("A1:E4").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
            ' Wenn alles läuft diese Zeile entfernen, ist nur zum testen 
            Stop
            ' Zeile 2 wird gelöscht. Vertikal verbundene Zellen sind vorhanden 
            ' das funktioniert auch, wenn keine 
            ' verbundenen Zellen vorhanden sind 
            objWDDoc.Tables(1).Cell(2, 1).Delete wdDeleteCellsEntireRow
        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    : Module1 
' Procedure : OffApp 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 28.01.2013 
' 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

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

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