[Excel] Auswahl von Tabelleninhalt nach Word kopieren

josef24

Erfahrenes Mitglied
Hallo zusammen, ich versuche gefilterte Tabelleninhalte aus EXCEL nach Word zu kopieren. Das Kopieren klappt. Die Tabelle "Problemfälle" beinhaltet die kompl. Tabelle. Aus der Tabelle "TuduList" soll in Word kopiert werden. Die "Filterfunktion" funktioniert nicht. Hierin besteht mein Problem. Kann mir hierbei jemand helfen den Code zum richtigen Ergebnis zu führen. Gruß Josef

Hier mal mein VBA Code:

Visual Basic:
Public Sub cmdTuDuList_Click()
    pfadZurVorlage = "C:\Users\Besitzer\Desktop\Word Vorlagen\Tudu_List.dotx"
    Set obj_Wd = CreateObject("WORD.Application")
    Set obj_Doc = obj_Wd.Documents.Add(Template:=pfadZurVorlage)
    obj_Doc.Windows(1).Visible = True
    
        Set wsh_Q = ThisWorkbook.Worksheets("ArbTab")  '  ("ArbTab")
        Set liO = wsh_Q.ListObjects(1)
        
            Set wsSource = ActiveWorkbook.Worksheets("Problemfälle")  '  ("TuduList")
            Set wsTarget = ActiveWorkbook.Worksheets("TuduList")      '  ("Problemfälle")
          
          liO.Autofilter.ShowAllData
 
    wsTarget.UsedRange.ClearContents
    Set wsFilter = ActiveWorkbook.Worksheets.Add()
    wsFilter.Name = "FILTER"
    
        wsFilter.Range("A1").Value = wsSource.Range("F1").Value     ' Spalte Bemerkung
        wsFilter.Range("B1").Value = wsSource.Range("E1").Value     ' Tage gültig
        wsFilter.Range("C1").Value = wsSource.Range("H1").Value     ' Austritt Datum
    
            wsFilter.Range("A2").Value = ">A*"            ' Spalte Bemerkung
            wsFilter.Range("B3").Value = "<=260"          ' Tage gültig
            wsFilter.Range("C4").Value = "<=31.12.2022"     ' Austritt Datum
    
    wsSource.UsedRange.AdvancedFilter xlFilterCopy, wsFilter.UsedRange, wsTarget.Range("A1"), False
    Application.DisplayAlerts = False
         wsFilter.Delete
    Application.DisplayAlerts = True
    If Not wsTarget.Visible Then
    wsTarget.Visible = True
    wsTarget.Select
    
        Set wsSource = Nothing
        Set wsTarget = Nothing
        Set wsFilter = Nothing
 End If
    
'    liO.Range.AutoFilter Field:=15, Criteria1:=">=1", Operator:=xlAnd, Criteria2:="<=40"  ' Ist gleich TAGE gültid
'        liO.Range.AutoFilter Field:=22, Criteria1:="<A"
'            liO.Range.AutoFilter Field:=12, Criteria1:=">=1"

    With liO.Range
        .Columns.Hidden = True
        .Columns(2).ColumnWidth = 13
        .Columns(4).ColumnWidth = 13
        .Columns(5).ColumnWidth = 10
        .Columns(13).ColumnWidth = 10
        .Columns(15).ColumnWidth = 10
        .Columns(21).ColumnWidth = 10
        .Columns(14).ColumnWidth = 12
        .Columns(12).ColumnWidth = 15
    End With
    
    liO.Range.Cells(1).CurrentRegion.Copy
    obj_Doc.bookmarks("Anrede").Range.Paste
    liO.Range.Columns.Hidden = False
    liO.Autofilter.ShowAllData
    MsgBox "fertig"
    
    Set obj_Wd = Nothing
    Set obj_Doc = Nothing
    Set wsh_Q = Nothing
    Set liO = Nothing
End Sub
 
Zuletzt bearbeitet:
Zurück