hier ein Vorschlag...
23.11.2013 11:31:39
Tino
Hallo,
kannst mal so versuchen.
In der Sub FilterDaten kommt noch diese Zeile hinzu.
ReDim Preserve ArFilter(1 To UBound(ArFilter), 1 To nCount)
Private Sub Ändern_Click()
Dim ZielZeile As Long
'kein Datensatz ausgewählt
If Personalien.ListIndex = -1 Then Exit Sub
'Zeile aus Listbox auslesen
If IsNumeric(Personalien.List(, 9)) Then
ZielZeile = Personalien.List(, 9)
Else 'Eintrag hat keine Zeilennummer (sollte aber nicht vorkommen!)
Exit Sub
End If
On Error GoTo ErrFehler:
Application.ScreenUpdating = False
With Worksheets("Jahrestabelle")
.Protect Password:="*****", UserInterfaceonly:=True
.Cells(ZielZeile, 4) = Familienname.Text
.Cells(ZielZeile, 5) = Vorname.Text
.Cells(ZielZeile, 6) = CDate(GebDatum)
.Cells(ZielZeile, 8) = CDate(Datum)
.Cells(ZielZeile, 9) = Störung.Text
.Cells(ZielZeile, 10) = Straftat.Text
.Cells(ZielZeile, 11) = Verweis.Text
.Cells(ZielZeile, 12) = OE.Text
.Cells(ZielZeile, 13) = Eigene.Text
End With
ErrFehler:
Unload Me
Worksheets("Dateneingabe").Activate
Application.ScreenUpdating = True
If Err.Number <> 0 Then
MsgBox Err.Description, _
vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
"Error: " & Err.Number, Err.HelpFile, Err.HelpContext
End If
End Sub
Private Sub TextBox1_Change()
Call FilterDaten(TextBox1, TextBox2, TextBox3)
End Sub
Private Sub TextBox2_Change()
Call FilterDaten(TextBox1, TextBox2, TextBox3)
End Sub
Private Sub TextBox3_Change()
Call FilterDaten(TextBox1, TextBox2, TextBox3)
End Sub
Private Sub UserForm_Activate()
Call FilterDaten
End Sub
Private Sub FilterDaten(Optional sFilter1$, Optional sFilter2$, Optional sFilter3$)
Dim ArData, ArFilter()
Dim X As Long, n&, nn&, nCount&
Me.Personalien.Clear
With Worksheets("Jahrestabelle")
X = Range("D" & Rows.Count).End(xlUp).Row
If X < 5 Then Exit Sub
ArData = .Range("D5", .Cells(X, 13))
End With
Redim Preserve ArFilter(1 To Ubound(ArData, 2) + 1, 1 To Ubound(ArData) + 1)
If sFilter1 & sFilter2 & sFilter3 = "" Then
For n = 1 To Ubound(ArData)
nCount = nCount + 1
For nn = 1 To Ubound(ArData, 2) - 1
ArFilter(nn, nCount) = ArData(n, nn)
Next nn
ArFilter(nn, nCount) = n + 4
Next n
Else
sFilter1 = sFilter1 & "*"
sFilter2 = sFilter2 & "*"
sFilter3 = sFilter3 & "*"
For n = 1 To Ubound(ArData)
If ArData(n, 1) Like sFilter1 Then
If ArData(n, 2) Like sFilter2 Then
If ArData(n, 3) Like sFilter3 Then
nCount = nCount + 1
For nn = 1 To Ubound(ArData, 2) - 1
ArFilter(nn, nCount) = ArData(n, nn)
Next nn
ArFilter(nn, nCount) = n + 4
End If
End If
End If
Next n
End If
If nCount > 0 Then
Redim Preserve ArFilter(1 To Ubound(ArFilter), 1 To nCount)
Personalien.ColumnCount = Ubound(ArFilter)
Personalien.List = Application.Transpose(ArFilter)
Else
MsgBox "keine Daten gefunden"
End If
End Sub
Gruß Tino