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:
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: