AW: Zeitraum filtern
21.07.2020 09:04:10
Nepumuk
Hallo Senna,
teste mal:
Option Explicit
Public Sub Datumsfilter()
Dim strInput As String
Dim dtmFrom As Date, dtmTo As Date
Dim astrNames() As String
Dim ialngIndex As Long
Dim objCell As Range
Dim objWorksheet As Worksheet
Do
strInput = InputBox("Bitte das Datum eingeben.", "Eingebe")
If StrPtr(strInput) = 0 Then Exit Sub
If IsDate(strInput) Then Exit Do
Call MsgBox("Bitte ein gültiges Datum eingeben.", vbExclamation, "Hinweis")
Loop
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
dtmTo = CDate(strInput)
dtmFrom = dtmTo - 7
With Worksheets("Tabelle1") 'Anpassen !!!
Call .Rows(1).AutoFilter(Field:=8, Criteria1:=">=" & _
CStr(Clng(dtmFrom)), Criteria2:="<=" & CStr(Clng(dtmTo)))
Redim astrNames(0)
For Each objCell In .Range(.Cells(2, 3), _
.Cells(.Rows.Count, 3).End(xlUp)).SpecialCells(Type:=xlCellTypeVisible)
If UBound(Filter(SourceArray:=astrNames, Match:=objCell.Text)) = -1 Then
Redim Preserve astrNames(ialngIndex)
astrNames(ialngIndex) = objCell.Text
ialngIndex = ialngIndex + 1
End If
Next
For ialngIndex = LBound(astrNames) To UBound(astrNames)
For Each objWorksheet In ThisWorkbook.Worksheets
If objWorksheet.Name = astrNames(ialngIndex) Then Exit For
Next
If objWorksheet Is Nothing Then
Set objWorksheet = ThisWorkbook.Worksheets.Add
objWorksheet.Name = astrNames(ialngIndex)
Else
Call objWorksheet.UsedRange.ClearContents
End If
Call .Rows(1).AutoFilter(Field:=3, Criteria1:=astrNames(ialngIndex))
Call .AutoFilter.Range.Copy(Destination:=objWorksheet.Cells(1, 1))
Next
Call .ShowAllData
Set objWorksheet = Nothing
End With
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
Gruß
Nepumuk
