Hallo liebe VBA-Programmierer

ich hoffe ihr könnt mir bei folgendem Problem beistehen.

In meiner Excel Datei werden per VBA-Makro Daten in der Tabelle "Bestand" gespeichert.
Die Daten verteilen sich pro Eingabe in einer Zeile auf die zellen "A" bis "J"
Durch mehrmaliges Anwenden des VBA-Makros zum Speichern enstehen in der Tabelle "Eingabedaten" Duplikate.

Ich kann bereits mit meinem Code die Daten der Tabelle "Bestand" durchsuchen und in der Tabelle "Eingabe" anzeigen lassen.
Nur zeigt mir mein Code alle Duplikate einzelnd in einer Zeile an. Wäre es möglich die herausgesuchten Duplikate in der Tabelle "Eingabe" bis auf einen zu löschen
und in der gleichen Zeile in Zelle "J" die Anzahl der gleichen Datensätze anzuzeigen?

Mir wäre is nur wichtig das die Suchkriterein/Eingenschaften des Codes gleich bleiben.

Mein Bestehender Code lautet:

Dim rBereich As Range
  Dim sIchsuche As String, sErsteAdresse As String
  Dim sBer As String, sArr() As String
  Dim WSh As Worksheet, iZeile As Long, i As Long, iGefunden As Long
  Dim bCheck As Boolean

  sIchsuche = TextBox1
  If StrPtr(sIchsuche) = 0 Then Exit Sub
  If sIchsuche = "" Then
     MsgBox "Nix kon ma ned findn!", vbCritical, "Suche"
     Exit Sub
  End If

  Set WSh = Worksheets("Eingabe")
  WSh.Range("A8:J1000").Clear
 

With Worksheets("Bestand").Range("A:J")
      sArr = Split(sIchsuche)
      Set rBereich = .Find(sArr(0), LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
      If Not rBereich Is Nothing Then
         sErsteAdresse = rBereich.Address
         Do
            iZeile = WSh.Cells(Rows.Count, "A").End(xlUp).Row + 1
            If iZeile < 8 Then iZeile = 8
            bCheck = True
            If UBound(sArr) > 0 Then
               For i = 1 To UBound(sArr)
                   On Error Resume Next
                   sBer = rBereich.Row & ":" & rBereich.Row
                   If Application.WorksheetFunction.Match(sArr(i) & "*", .Range(sBer), 0) = 0 Then
                      bCheck = False: Exit For
                   End If
                  Next i
               On Error GoTo 0
            End If
            If bCheck Then
               rBereich.EntireRow.Copy WSh.Cells(iZeile, "A").EntireRow
            End If
            Set rBereich = .FindNext(rBereich)
         Loop While Not rBereich Is Nothing And rBereich.Address <> sErsteAdresse

      End If
  End With

  
If Worksheets("Eingabe").Range("A8") = "" Then

MsgBox "'" & sIchsuche & "' hama ned, zefix!" & vbCrLf & vbCrLf & "- schreibs a bissal anders" & vbCrLf & "- ggf bestellen", vbCritical, "Suche"

End If

Vielen Dank für die schnelle Hilfe

Gruß

Florian