Hallo Ihr zwei Mitkämpfer, :)
Ihr dürft loslegen, wie verrückt.
Ich schnall mir dann die Gummisocken an und mache mich auf an den Rhein. Bis Donnerstagabend habt Ihr Ruhe vor mir.
@Erich:
Ganz ehrlich? Schmeiß die beiden Spalten raus.
Die Zeile steht vorn im Sheet und die Anzahl bekommst Du unten links in der Statuszeile mitgeteilt.
Zusätzlich auch im Userform, wenn Du folgendes machst:
Lösche die Sub "Private Sub SetFilter(Optional Value As Integer = 0)"
Code:
'die alte Sub komplett mit dieser ersetzen:
Private Sub SetFilter(Optional Value As Integer = 0)
On Err GoTo Er
Dim i As Long, rowsCount As Long
With Sheets(Me.MySheetName)
If .AutoFilterMode Then .AutoFilterMode = False
If Value <> 0 Then
i = Value
Else
i = GetFilterSetting
End If
'Anzahl vor dem filtern merken:
rowsCount = Me.MyLastCell - Me.MyFirstDataRow + 1
Select Case i
Case 1
.Range(Me.MyFirstColumn & Me.MyFirstDataRow - 1 & ":" & Me.MyLastColumn & _
Me.MyLastCell).AutoFilter Field:=Column2Nr(Me.MyDmcCodeColumn), Criteria1:=Me.MySearchString
i = GetRows(.Range(Me.MyFirstColumn & Me.MyFirstDataRow - 1 & ":" & Me.MyLastColumn & Me.MyLastCell))
ListEntryAdd "Filter ""DMC-Code"", Suchbedingungen: Datum: " & Me.txtDate & _
", Suchstring: " & Me.txtSearchString & vbTab & i & " von " & rowsCount & " gefunden"
Application.Goto Reference:=.Cells(Me.MyRowNumber, Me.MyFirstColumn), Scroll:=True
Case 2
.Range(Me.MyFirstColumn & Me.MyFirstDataRow - 1 & ":" & Me.MyLastColumn & _
Me.MyLastCell).AutoFilter Field:=Column2Nr(Me.MyOffset1Column), Criteria1:=Me.MyOutputString
i = GetRows(.Range(Me.MyFirstColumn & Me.MyFirstDataRow - 1 & ":" & Me.MyLastColumn & Me.MyLastCell))
ListEntryAdd "Filter ""Kdn-/Bestell-Nr"", Suchbedingung: " & Me.txtNumber & _
vbTab & i & " von " & rowsCount & " gefunden"
Application.Goto Reference:=.Cells(Me.MyRowNumber, Me.MyFirstColumn), Scroll:=True
Case Else
.Range(Me.MyFirstColumn & Me.MyFirstDataRow - 1 & ":" & Me.MyLastColumn & Me.MyLastCell).AutoFilter
End Select
End With
Ex:
Application.ScreenUpdating = True
Exit Sub
Er:
Application.ScreenUpdating = True
MsgBox Err.Number & vbNewLine & Err.Description, vbCritical, "Fehler in SearchAndSetNumber"
Resume Ex
'for debug:
Resume Next
End Sub
'und zusätzlich noch diese Funktion neu einfügen:
Private Function GetRows(ByVal MyRange As Range) As Long
'Error, wenn es keine sichtbaren Zellen gibt. Deshalb:
On Error Resume Next
GetRows = MyRange.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
End Function
Das Ergebnis sieht in etwa so aus:
Da kannst Du nochmal nachträglich nachschauen/kontrollieren. Damit sollten die beiden Kummer machenden Spalten entfallen können. (Auch wenn Du Dir für die Formeln vielleicht viel Mühe gegeben haben solltest ...)
@Atilla:
Leg los, Du darfst.
In .Net legt man einfach ein Objekt in den Tag des ListItems und fertig.
Geht hier in VBA meines Wissens nicht so. Ich würde der Einfachheit halber neben der Liste eine Collection füllen und das Objekt mit dem Listindex aufrufen.
Vielleicht hast Du eine bessere Idee.
Und reinschauen tu ich schon mal ... ;)
Bis denne,
Gruß Carsten
;)
Edit:
Wieder mit Erichs Posting überschnitten :D
Habe zu lange benötigt.
Erich, reicht das so aus?
![[-]](https://www.clever-excel-forum.de/images/collapse.png)