AW: Listbox nach Datum filtern
05.02.2016 18:54:17
Tino
Hallo,
hier mal ein Beispiel.
kommt als Code in UserForm1
Option Explicit
Private Sub DTPicker1_Change()
Call FilterDaten(DTPicker1.Value, DTPicker2.Value, 1)
End Sub
Private Sub DTPicker2_Change()
Call FilterDaten(DTPicker1.Value, DTPicker2.Value, 1)
End Sub
'vonDate= Filter von, bisDate= Filter bis, lngCol= Spalte wo Datum
Private Sub FilterDaten(vonDate As Date, bisDate As Date, lngCol&)
Dim ArData
Dim NewAr()
Dim n&, nn&, nCount&
If vonDate <= bisDate Then
ArData = DatenBereich.Value
ArData = Application.Transpose(ArData)
Redim Preserve NewAr(1 To Ubound(ArData), 1 To Ubound(ArData, 2))
For n = 1 To Ubound(ArData, 2)
If IsNumeric(ArData(lngCol, n)) Then
If CDate(ArData(lngCol, n)) >= vonDate Then
If CDate(ArData(lngCol, n)) <= bisDate Then
nCount = nCount + 1
For nn = 1 To Ubound(ArData)
NewAr(nn, nCount) = ArData(nn, n)
Next nn
End If
End If
End If
Next n
End If
If nCount > 0 Then
Redim Preserve NewAr(1 To Ubound(NewAr), 1 To nCount)
If nCount > 1 Then
NewAr = Application.Transpose(NewAr)
ListBox1.List = NewAr
Else
ListBox1.Clear
ListBox1.AddItem NewAr(1, 1)
For n = 2 To Ubound(NewAr)
ListBox1.List(0, n - 1) = NewAr(n, 1)
Next n
End If
Else
ListBox1.Clear
End If
End Sub
Private Sub UserForm_Initialize()
Dim ArData
ArData = DatenBereich.Value
With ListBox1
.ColumnCount = Ubound(ArData, 2)
.List = ArData
End With
Call FilterDaten(DTPicker1.Value, DTPicker2.Value, 1)
End Sub
Private Function DatenBereich() As Range
With Tabelle1
Set DatenBereich = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 2)
End With
End Function
Gruß Tino