AW: Sortieren von bis
28.11.2008 13:30:00
bis
Hallo Hardy,
hier mein Vorschlag. In der Zeile 1 von Tabelle 2 und 3 sind dabei Spaltentitel eingetragen.
Gruß
Franz
Option Explicit
Private wksQuelle As Worksheet, wksZiel As Worksheet, wksFilter As Worksheet
Private objFilter As Filter
Sub DatenAufbereiten()
Call DatenUebernehmen
Call DatenFiltern
End Sub
Sub DatenUebernehmen()
Set wksQuelle = Worksheets("Tabelle1")
Set wksZiel = Worksheets("Tabelle2")
'Altdaten in Ziel ab Zeile 2 löschen
With wksZiel
If .AutoFilterMode = True Then
For Each objFilter In .AutoFilter.Filters
If objFilter.On = True Then
.ShowAllData
Exit For
End If
Next
End If
If .Cells(.Rows.Count, 1).End(xlUp).Row > 1 Then
.Range(.Rows(2), .Rows(.Cells(.Rows.Count, 1).End(xlUp).Row)).ClearContents
End If
End With
'Daten-Zeilen aus Quelle ab Zeile 1 nach Ziel ab Zelle A2 kopieren
With wksQuelle
.Range(.Rows(1), .Rows(.Cells(.Rows.Count, 1).End(xlUp).Row)).Copy _
Destination:=wksZiel.Cells(2, 1)
End With
End Sub
Sub DatenFiltern()
Set wksFilter = Worksheets("Tabelle2")
Set wksZiel = Worksheets("Tabelle3")
'Altdaten in Ziel-Tabelle ab Zeile 2 löschen
With wksZiel
If .Cells(.Rows.Count, 1).End(xlUp).Row > 1 Then
.Range(.Rows(2), .Rows(.Cells(.Rows.Count, 1).End(xlUp).Row)).ClearContents
End If
End With
With wksFilter
If .AutoFilterMode = True Then
'ggf. alle Daten anzeigen und Autofilter abschalten
For Each objFilter In .AutoFilter.Filters
If objFilter.On = True Then
.ShowAllData
.AutoFilterMode = False
Exit For
End If
Next
End If
'Spalten A bis D sortieren und Autofilter setzen
With .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 3))
'Autofilter aktivieren für Spalten A bis D
.AutoFilter
'Daten nach Spalte B sortieren
.Sort Key1:=.Range("B1"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'Filter für Spalte D setzen
.AutoFilter Field:=4, Criteria1:="A"
'Filter mit Datumsbereich für Spalte B setzen
.AutoFilter Field:=2, Criteria1:=">=" & CDbl(.Range("H1").Value), _
Operator:=xlAnd, Criteria2:=" 1 Then
.Range(.Cells(2, 2), .Cells(.Rows.Count, 4).End(xlUp)).EntireRow.Copy _
Destination:=wksZiel.Cells(2, 1)
Application.CutCopyMode = False
Else
MsgBox "Filter ergab keine zu kopierenden Daten!"
End If
End With
wksZiel.Activate
End Sub