Thema Datum  Von Nutzer Rating
Antwort
Rot Duplikate löschen und Anzahl anzeigen
09.07.2021 13:33:18 Florian
NotSolved
09.07.2021 16:34:12 Gast30655
NotSolved
09.07.2021 17:45:22 Gast93466
NotSolved
09.07.2021 19:52:58 Florian
NotSolved
09.07.2021 20:01:05 Gast94023
NotSolved
09.07.2021 20:46:52 Florian
NotSolved
10.07.2021 11:29:46 Gast76842
NotSolved
11.07.2021 12:54:31 Florian
NotSolved

Ansicht des Beitrags:
Von:
Florian
Datum:
09.07.2021 13:33:18
Views:
76
Rating: Antwort:
  Ja
Thema:
Duplikate löschen und Anzahl anzeigen

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 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:

 
 

  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot Duplikate löschen und Anzahl anzeigen
09.07.2021 13:33:18 Florian
NotSolved
09.07.2021 16:34:12 Gast30655
NotSolved
09.07.2021 17:45:22 Gast93466
NotSolved
09.07.2021 19:52:58 Florian
NotSolved
09.07.2021 20:01:05 Gast94023
NotSolved
09.07.2021 20:46:52 Florian
NotSolved
10.07.2021 11:29:46 Gast76842
NotSolved
11.07.2021 12:54:31 Florian
NotSolved