Suche nach Spalte B,C,D mit Ausgabe in einer Listbox

Private Sub txtSearch_AfterUpdate()
Application.ScreenUpdating = False

Dim appExcel As Excel.Application
Dim wbkExcel As Excel.Workbook
Dim wksExcel As Excel.Worksheet
 
Set appExcel = Excel.Application
Set wbkExcel = Excel.Workbooks.Open("C:\VBA\tbl_ArtStamm.xlsx", ReadOnly:=True)  
Set wksExcel = Excel.Worksheets("ArtStamm")  
Set rngExcel = wksExcel.UsedRange

Dim strSearchTerm As String, dic As Object, arrSearchTerms As Variant, firstAddress As String, c As Range, keys As Variant
Set dic = CreateObject("Scripting.Dictionary")  
lbResults.Clear
Windows("tbl_ArtStamm.xlsx").Activate  

Dim Suchbegriff As String
Suchbegriff = Me.txtSearch
If Right$(Suchbegriff, 1) = " " Then 'Wenn das letzte Zeichen ein Leerzeichen ist, gibt es keine Suchtreffer  
'Also letztes Leerzeichen entfernen  
Me.txtSearch.Text = Left(Me.txtSearch, Len(Me.txtSearch) - 1)
Else
'Sonst nichts entfernen  
End If

With ActiveSheet.Range("D:D")  
arrSearchTerms = Split(txtSearch.Text, " ", -1, vbTextCompare)  
'Suche jedes Wort  
For I = 0 To UBound(arrSearchTerms)
'Suche durchführen  
Set c = .Find(arrSearchTerms(I), LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
Do
If I <> 0 Then

'Es wurde schon nach dem ersten Suchwort gesucht also zähle nur 1 hinzu wenn die gefundene Zelle im Dictionary enthalten ist  
If dic.Exists(c.Address) Then
dic.Item(c.Address) = dic.Item(c.Address) + 1
End If
Else
'Erstes Suchwort, also füge es zum Dictionary hinzu  
dic.Add c.Address, 1
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
Next
'Wenn Suchergebnisse da sind ...  
If dic.Count > 0 Then
' Durchlaufe alle Einträge im Dictionary und prüfe ob der Wert der Anzahl der Suchworte entspricht.  
' Wenn ja, füge ihn zur Listbox hinzu  
Set rngResult = Nothing
keys = dic.keys()
For I = 0 To dic.Count - 1
If dic.Item(keys(I)) = UBound(arrSearchTerms) + 1 Then
Set rngFound = ActiveSheet.Range(keys(I))

With lbResults
.AddItem
.List(.ListCount - 1, 0) = rngFound.Offset(0, -3).Value 'ID  
.List(.ListCount - 1, 1) = rngFound.Offset(0, -2).Value ' ArtNr.  
.List(.ListCount - 1, 2) = rngFound.Offset(0, -1).Value ' MEH  
.List(.ListCount - 1, 3) = rngFound.Value ' Bezeichnung  
.List(.ListCount - 1, 4) = rngFound.Offset(0, 1).Value ' Bezeichnung lang  
.List(.ListCount - 1, 5) = rngFound.Offset(0, 2).Value ' Info  
End With
End If
Next
Else
'Keine Suchergebnisse  
MsgBox "Keine Einträge gefunden!", vbExclamation  
End If
End With

'Überschriften  
lbResults.ColumnCount = 7
lbResults.ColumnWidths = "0,00Pt; 42,5Pt; 28,35Pt; 198,45Pt; 0,00Pt; 0,00Pt; 0,00Pt"  
Me.lbResultsHeader.RowSource = ActiveSheet.Range("A1:G1").Address  

wbkExcel.Close
Application.ScreenUpdating = True
End Sub