Autofilter Abhängig von der Anzahl der Werte in der Spalte
05.03.2024 13:12:06
Max_Bot
Ich habe einen Datensatz, bestehend aus einer Auflistung von Bauteilen. Insgesamt knapp 32000 Bauteile, von denen ich teilweise mehrere mit der gleichen Bezeichnung habe. Für mich sind nur die Bauteile interessant, die mindestens 10mal aufgeführt wurden. Ich habe versucht, einen Code für einen Autofilter zu erstellen.
Leider funktioniert das nur mäßig. Zur Kontrolle und für die weitere Verarbeitung lasse ich mir die Bauteile und die Häufigkeit der Bauteile in einer Listbox anzeigen.
Hier mein Ansatz für den nicht funktionierenden Autofilter:
Private Sub Test_Click()
Dim tbl As ListObject
Dim rng As Range
Dim cell As Range
Dim dict As Object
Dim count As Integer
Set tbl = ThisWorkbook.Sheets("Abfrage1").ListObjects("Abfrage1")
Set rng = tbl.ListColumns("Bezeichnung Bauteil").DataBodyRange
Set dict = CreateObject("Scripting.Dictionary")
For Each cell In rng
If cell.Value > "" Then
If dict.exists(cell.Value) Then
dict(cell.Value) = dict(cell.Value) + 1
Else
dict.Add cell.Value, 1
End If
End If
Next cell
tbl.Range.AutoFilter Field:=rng.Column
For Each Key In dict.keys
If dict(Key) 10 Then
tbl.Range.AutoFilter Field:=rng.Column, Criteria1:=">" & Key
End If
Next Key
MsgBox "Filtern abgeschlossen."
Set dict = Nothing
End SubDie Ergebnisse aus der Tabelle kontrolliere ich in der Listbox.
Soweit ich das erkenne, funktioniert das wie gewollt.
Private Sub cb_Auführen1_Click()
Me.ListBox1.Clear
HäufigsteWörterInListbox
End Sub
Sub HäufigsteWörterInListbox()
ListBox1.ColumnCount = 2
Dim tbl As ListObject
Dim wordRange As Range
Dim wordCount As Long
Dim i As Long
Dim wordDict As Object
Dim word As Variant
Dim sortedWords() As Variant
Dim sortedCounts() As Variant
Dim j As Long
Set tbl = ActiveSheet.ListObjects("Abfrage1")
Set wordRange = tbl.ListColumns("Bezeichnung Bauteil").DataBodyRange
Set wordDict = CreateObject("Scripting.Dictionary")
On Error Resume Next
For Each word In wordRange.SpecialCells(xlCellTypeVisible)
If Not wordDict.exists(word.Value) Then
wordDict.Add word.Value, 1
Else
wordDict(word.Value) = wordDict(word.Value) + 1
End If
Next word
On Error GoTo 0
ReDim sortedWords(1 To wordDict.count)
ReDim sortedCounts(1 To wordDict.count)
i = 1
For Each word In wordDict.keys
sortedWords(i) = word
sortedCounts(i) = wordDict(word)
i = i + 1
Next word
For i = 1 To wordDict.count - 1
For j = i + 1 To wordDict.count
If sortedCounts(j) > sortedCounts(i) Then
Dim tempWord As Variant
Dim tempCount As Variant
tempWord = sortedWords(i)
tempCount = sortedCounts(i)
sortedWords(i) = sortedWords(j)
sortedCounts(i) = sortedCounts(j)
sortedWords(j) = tempWord
sortedCounts(j) = tempCount
End If
Next j
Next i
For i = 1 To 1000
If i > wordDict.count Then Exit For
Me.ListBox1.AddItem sortedWords(i)
Me.ListBox1.List(i - 1, 1) = sortedCounts(i)
Next i
End Sub
Hat jemand eine Idee wie man den Autofilter ans laufen bekommt?
Danke im voraus!
Gruß
Max