title image


Smiley hier meine Lösung
Leider habe ich lizenzgerecht keinen Syntaxhighlighter in der Firma, deshalb etwas unschön. Vorbedingungen sind ein schon vorhandener Autofilter und ein exakt identischer Tabellenaufbau. Das hätte man ausprogrammieren können, aber die Zeit reichte nicht :-)



Dim i&, filterArray(), currentFiltRange$



Set VNR1 = ActiveWorkbook.Sheets("VNR1")

Set VNR2 = ActiveWorkbook.Sheets("VNR2")



'Autofilter VNR1 einlesen

With VNR1.AutoFilter

With .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

End With



'Autofilter VNR2 setzen

currentFiltRange = VNR2.AutoFilter.Range.Address

For i = 1 To UBound(filterArray(), 1)

If Not IsEmpty(filterArray(i, 1)) Then

If filterArray(i, 2) Then

VNR2.Range(currentFiltRange).AutoFilter field:=i, _

Criteria1:=filterArray(i, 1), _

Operator:=filterArray(i, 2), _

Criteria2:=filterArray(i, 3)

Else

VNR2.Range(currentFiltRange).AutoFilter field:=i, _

Criteria1:=filterArray(i, 1)

End If

End If

Next



Das entspricht im wesentlichen der Windows-Hilfe. Warum man die Objekte nicht direkt kopieren kann, habe ich nicht ergründen können.



Danke auch nochmal für Deinen zerbrochenen Kopf



Gruß

Marco

geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: