Excel Filter in andere Tabelle übernehmen

[Backdraft]

Hi Leute.

Ich versuche die ganze Zeit Excel-Filter zu übernehmen. :mauer:

Das heißt, Tabelle1 (Bestand neu) hat mehrere Feldnamen mit einträgen wie z.B. Bezeichnung, Seriennr., Typ, Hersteller .... usw..
Die haben auch alle einen Filter.
Nun habe ich eine neue Tabelle2 (Entnahme-Rückgabe) auf der gleichen Datei erstellt und möchte den Filter wie z.B. von Bezeichnung mit nutzen oder kopieren.

Zweck: Warenausgabe aus dem Lager brauche ich dann nicht immer wieder einen Zettel schreiben.
Einfach auf dem Vordruck auswählen und drucken.

Wie geht das ??? :(

Kann ich auch wenn ich den Filter von der Bezeichnung übernommen habe auch die Seriennr in eine andere Spalte mit übernehmen ?? :confused:

Thnx für eure HILFE !!!

[tweakyou]

hi Backdraft,

wenn ich dich richtig verstanden habe willst du eine Tabelle incl. der Autofilter kopieren.
Ich denke mal der folgende Code hilft dir weiter.


'--------------------------------------------------------------------------------
Public Sub copyWorksheetWithFilters(aWksSrc As Worksheet, _
aWksDst As Worksheet)
Dim i As Long
Dim lastRow As Long
Dim lastColumn As Long
Dim filterRange As String
Dim filterArray() As Variant
Dim rng As Range

With aWksSrc
'--- exit if no filter set
If .FilterMode = False Then Exit Sub

'--- store filter settings in an array
filterRange = .AutoFilter.Range.Address
With .AutoFilter.filters
ReDim filterArray(1 To .Count, 1 To 3)
For i = 1 To .Count
With .Item(i)
If .On Then
filterArray(i, 1) = .Criteria1
If .Operator Then
filterArray(i, 2) = .Operator
filterArray(i, 3) = .Criteria2
End If
End If
End With
Next
End With

'--- switch AutofilterMode off
.AutoFilterMode = False

'--- copy used range
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set rng = .Range(.Cells(1, 1), .Cells(lastRow, lastColumn))
rng.Copy aWksDst.Cells(1)
End With

'--- restore autofilter settings
Call setFilter(aWksSrc, filterRange, filterArray)
'--- copy autofilter settings
Call setFilter(aWksDst, filterRange, filterArray)

End Sub
'--------------------------------------------------------------------------------
Public Sub setFilter(aWks As Worksheet, _
aFilterRange As String, _
aFilterArray() As Variant)
Dim i As Long

With aWks
For i = 1 To UBound(aFilterArray(), 1)
If Not IsEmpty(aFilterArray(i, 1)) Then
With .Range(aFilterRange)
If aFilterArray(i, 2) Then
.AutoFilter field:=i, _
Criteria1:=aFilterArray(i, 1), _
Operator:=aFilterArray(i, 2), _
Criteria2:=aFilterArray(i, 3)
Else
.AutoFilter field:=i, _
Criteria1:=aFilterArray(i, 1)
End If
End With
End If
Next
End With
End Sub
'--------------------------------------------------------------------------------
Sub TestCopyWorksheetWithFilters()
Call copyFilters(ThisWorkbook.Worksheets("Tabelle1"), _
ThisWorkbook.Worksheets("Tabelle2"))
End Sub
'--------------------------------------------------------------------------------
'EndOfCode
'--------------------------------------------------------------------------------