Word - Tabelle erstellen - Zeile löschen - Daten kopieren...

Frage: Nachfolgend ein paar Beispiele wie man in Word Tabellen erstellt, Zeilen in der Tabelle löscht, einen Zellbereich nach Word kopiert - natürlich alles aus Excel. Kommentare im Code.

Here are a few examples of how to create tables in Word, delete rows in the table, copying a range of cells to Word - of course everything from Excel. Comments in the code.

Hier noch eine Beispieldatei / Here's a sample file:
Word - Tabelle erstellen - Zeile löschen - Daten kopieren...[ZIP 50 KB]

Code gehört in ein Modul (Module1) / Code belongs in a module (Module1):

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 24.01.2013 
' Purpose   : Open Word from Excel insert data and delete table row... 
'-------------------------------------------------------------------------- 
Public Sub Main()
    Dim intCount1 As Integer
    Dim intCount2 As Integer
    Dim varRange As Variant
    Dim objTable As Object
    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
        ' Den Kopierbereich zuweisen 
        varRange = Sheet1.Range("A1:E4").Value
        ' Das Worddokument MIT Tabelle öffnen 
        Set objWDDoc = objWDApp.Documents.Open(ThisWorkbook.Path & _
            Application.PathSeparator & "Test_document_with_a_table.doc")
        ' Die erste Tabelle einer Objektvariablen zuweisen 
        Set objTable = objWDDoc.Tables(1)
        With objTable
            ' Die Daten in Schleifen eintragen 
            For intCount1 = 1 To Ubound(varRange, 1)
                For intCount2 = 1 To Ubound(varRange, 2)
                    .Cell(intCount1, intCount2).Range.InsertAfter _
                        varRange(intCount1, intCount2)
                Next intCount2
            Next intCount1
            ' Der Code stoppt hier. Jetzt die Worddatei anschauen 
            ' Diese Zeile kann/muss natürlich später raus - ist nur zum testen 
            Stop
            ' Die zweite Zeile der Wordtabelle wird gelöscht 
            .Rows(2).Delete
        End With
    End If
Fin:
    ' Objektvariablen zurücksetzen 
    Set objTable = Nothing
    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      : 24.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

Code gehört in ein Modul (Module2) / Code belongs in a module (Module2):

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Module2 
' Procedure : Main_1 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 24.01.2013 
' Purpose   : Open Word from Excel insert data and delete table row... 
'-------------------------------------------------------------------------- 
Public Sub Main_1()
    Dim intCount1 As Integer
    Dim intCount2 As Integer
    Dim varRange As Variant
    Dim objTable As Object
    Dim objWDApp As Object
    Dim objWDDoc As Object
    Dim lngCalc As Long
    Const wdStory = 6
    ' 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
        ' Den Kopierbereich zuweisen 
        varRange = Sheet1.Range("A1:E4").Value
        ' Das Worddokument OHNE Tabelle öffnen 
        Set objWDDoc = objWDApp.Documents.Open(ThisWorkbook.Path & _
            Application.PathSeparator & "Test_document_without_a_table.doc")
        ' Gehe ans Ende des Dokumentes 
        objWDApp.Selection.EndOf wdStory
        ' Die Objektvariable wird mit einer neu erstellten Tabelle gefüllt 
        Set objTable = objWDDoc.Tables.Add(objWDApp.Selection.Range, _
            Ubound(varRange, 1), Ubound(varRange, 2))
        With objTable
            ' Die Daten in Schleifen eintragen 
            For intCount1 = 1 To Ubound(varRange, 1)
                For intCount2 = 1 To Ubound(varRange, 2)
                    .Cell(intCount1, intCount2).Range.InsertAfter _
                        varRange(intCount1, intCount2)
                Next intCount2
            Next intCount1
            ' Der Code stoppt hier. Jetzt die Worddatei anschauen 
            ' Diese Zeile kann/muss natürlich später raus - ist nur zum testen 
            Stop
            ' Die zweite Zeile der Wordtabelle wird gelöscht 
            .Rows(2).Delete
        End With
    End If
Fin:
    ' Objektvariablen zurücksetzen 
    Set objTable = Nothing
    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    : Module2 
' Procedure : OffApp 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 24.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

Code gehört in ein Modul (Module3) / Code belongs in a module (Module3):

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Module3 
' Procedure : Main_2 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 24.01.2013 
' Purpose   : Open Word from Excel insert data... 
'-------------------------------------------------------------------------- 
Public Sub Main_2()
    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.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
        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      : 24.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)...