Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema InputBox
BildScreenshot zu InputBox InputBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema CommandButton
BildScreenshot zu CommandButton CommandButton-Seite mit Beispielarbeitsmappe aufrufen

Duplikate anzeigen/löschen

Betrifft: Duplikate anzeigen/löschen von: ToS2
Geschrieben am: 21.11.2014 15:59:37

Hallo zusammen,

Bin absoluter VBA-Neuling.

Hab einen netten Code gefunden mit dem man Duplikate finden kann.
Jetzt möcht ich doch gern dass dieser Code so umgebastelt wird dass er automatisch
die Zeile 2 Spalte A:I als Referenz nimmt
und in den Zeile 10 bis zum Ende der Liste (ca.1000 Zeilen) Spalten A:I auf Duplikate sucht (jeder Wert muss übereinstimmen).
Die Code sollte mit CommandButton2_Click() gestartet werden.

Hat jemand eine Lösung??

Es muss auch nicht dieser Code benutzt werden, entspricht aber meinen Wünschen:
Anzeige des Bereichs der Dupletten
Markierung
Frage ob gelöscht werden soll...

SG
ToS2

Sub DoppelteEintraegeLoeschen()
 'Uwe Küstner, 20060514
 Dim colUnique As New Collection
 Dim lngAbZeile As Long
 Dim lngArr As Long
 Dim lngC As Long
 Dim lngCalc As Long
 Dim lngDup As Long
 Dim lngMaxArrays As Long
 Dim lngZ As Long
 Dim lngZeile As Long
 Dim lngZeilenArray As Long
 Dim lngZeilenBereich As Long
 Dim rngArea As Range
 Dim rngAuswahl As Range
 Dim rngC As Range
 Dim rngDel() As Range
 Dim rngSel As Range
 Dim strSuchbereich As String
 Dim strZeile As String
 Dim varAuswahl() As Variant
 Dim varC As Variant
 Set rngSel = Selection.EntireColumn
 lngZeilenBereich = ActiveSheet.UsedRange.Rows.Count
 On Error GoTo FehlerBehandlung
 lngCalc = Application.Calculation
 Set rngAuswahl = _
 Application.Intersect(Selection.EntireColumn, ActiveSheet.UsedRange)
 strSuchbereich = rngAuswahl.Address(0, 0)
 lngAbZeile = Abs(CLng(Application.InputBox( _
 vbLf & "Ab welcher Zeile soll geprüft werden?", _
 "Prüfbereich festlegen", 2, , , , , 1)))
 If lngAbZeile > 0 And lngAbZeile <= lngZeilenBereich Then
  Set rngAuswahl = _
  Application.Intersect(Rows(lngAbZeile & ":" & lngZeilenBereich), rngSel)
 Else
  MsgBox "Die Zeile " & lngAbZeile & _
  " liegt außerhalb des Bereichs """ & strSuchbereich & """!"
  Exit Sub
 End If
 lngZeilenArray = lngZeilenBereich - lngAbZeile + 1
 rngAuswahl.Select
 lngArr = 1
 ReDim rngDel(lngArr)
 lngMaxArrays = lngZeilenBereich / 50
 strSuchbereich = rngAuswahl.Address(0, 0)
 Application.Calculation = xlCalculationManual
 Application.ScreenUpdating = False
 For Each rngArea In rngAuswahl.Areas
  For Each rngC In rngArea.Columns
   lngC = lngC + 1
   ReDim Preserve varAuswahl(1 To lngC)
   varAuswahl(lngC) = rngC.Value
  Next rngC
 Next rngArea
 colUnique.Add 0, "" 'wenn 1. Leerzeile auch berücksichtigt werden soll
 For lngZeile = 1 To lngZeilenArray
  strZeile = ""
  For lngZ = 1 To lngC
   strZeile = strZeile & CStr(varAuswahl(lngZ)(lngZeile, 1))
  Next lngZ
  colUnique.Add lngZeile, strZeile
 Next lngZeile
 Set rngDel(0) = rngDel(1)
 lngArr = lngArr + (rngDel(lngArr) Is Nothing)
 If lngArr > 1 Then
  For lngZ = 2 To lngArr
   Set rngDel(0) = Application.Union(rngDel(0), rngDel(lngZ))
  Next lngZ
 End If
 lngDup = rngDel(0).Cells.Count / 256
 Application.Intersect(rngSel, rngDel(0)).Select
 Application.ScreenUpdating = True
 If MsgBox("Es wurden " & lngDup & " Duplikate im Bereich" & vbLf & _
  strSuchbereich & vbLf & _
  "gefunden." & vbLf & vbLf & "Sollen sie jetzt gelöscht werden?", _
  vbQuestion Or vbYesNo Or vbDefaultButton2) = vbYes Then
  Application.ScreenUpdating = False
  For lngZ = lngArr To 1 Step -1
   rngDel(lngZ).Delete
  Next lngZ
  rngSel.Select
  Application.ScreenUpdating = True
 End If
 FehlerBehandlung:
 Select Case Err.Number
  Case 457
   If rngDel(lngArr) Is Nothing Then
    Set rngDel(lngArr) = Rows(lngZeile + lngAbZeile - 1)
   Else
    Set rngDel(lngArr) = _
    Application.Union(rngDel(lngArr), Rows(lngZeile + lngAbZeile - 1))
   End If
   If rngDel(lngArr).Areas.Count = lngMaxArrays Then
    lngArr = lngArr + 1
    ReDim Preserve rngDel(lngArr)
   End If
   Resume Next
  Case 13, 91
   MsgBox "Im Bereich" & vbLf & vbLf & """" & _
   strSuchbereich & """" & vbLf & vbLf & "gibt es keine Duplikate."
  Case Is > 0
   MsgBox "Fehlernummer: " & Err.Number & vbLf & vbLf & _
   "Felerbeschreibung: " & Err.Description
   'für Entwicklung zum Testen
   '      Application.Calculation = lngCalc
   '      On Error GoTo 0
   '      Resume
 End Select
 Application.Calculation = lngCalc
End Sub

  

Betrifft: AW: Duplikate anzeigen/löschen von: Tino
Geschrieben am: 21.11.2014 17:05:14

Hallo,
hier mal zum löschen.
Mit der Anzeige habe ich noch keine Idee weil es könnten ja auch alle sein, oder?

Sub start()
Dim rngRef As Range, rngData As Range, rngTmp As Range
Dim sVerkettenFormel$, n&

With Tabelle1 'Tabelle anpassen 
    'Ref 
    Set rngRef = .Range("A1:I1")
    'Datenbereich 
    Set rngData = Range("A10", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, rngRef.Columns.Count)
    If rngData.Rows(1).Row < 10 Then Exit Sub
    'letzte Spalte als Hilfsspalte 
    Set rngTmp = .Cells(rngData.Rows(1).Row, .Columns.Count).Resize(rngData.Rows.Count)
End With

'Formel zum verketten 
For n = 1 To rngRef.Columns.Count
    sVerkettenFormel = sVerkettenFormel & rngRef.Cells(1, n).Address(0, 1, xlR1C1) & "&"
Next n
sVerkettenFormel = Left$(sVerkettenFormel, Len(sVerkettenFormel) - 1)


With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
        
        'Formel Zeile 1 
        .Cells(rngRef.Rows(1).Row, .Columns.Count).FormulaR1C1 = "=" & sVerkettenFormel
        'Formel Zeilen Datenbereich 
        rngTmp.FormulaR1C1 = "=IF(R" & rngRef.Rows(1).Row & "C=" & sVerkettenFormel & ",TRUE,ROW())"
        'Sortieren 
        rngTmp.Sort rngTmp.Cells(1, 1), Order1:=xlAscending, Header:=xlNo
        'Formelergebnis Wahr vorhanden? 
        If Application.WorksheetFunction.CountIf(rngTmp, True) > 0 Then
            'lösche Zeilen mit Formelergebnis Wahr 
            rngTmp.SpecialCells(xlCellTypeFormulas, 4).EntireRow.Delete
        End If
        'Hilfspalte löschen 
        rngTmp.EntireColumn.Delete
    
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
End Sub
Gruß Tino


  

Betrifft: @Tino, Codedarstellung von: Matze Matthias
Geschrieben am: 21.11.2014 20:18:10

Hi Tino,
ich finde die Codedarstellung mit der farblichen Trennung klasse,
ist besser zu lesen las die hier im Forum über Code-pre-
Vermutlich haste das auch noch selbst entwickelt.
Woher würde ich an so etwas heran kommen bzw. wonach müsste ich da suchen?
Meine Email findest du oben im Profil, würde mich über eine Antwort freuen,

dankend Gruß Matze


  

Betrifft: AW: @Tino, Codedarstellung von: ToS2
Geschrieben am: 21.11.2014 20:31:08

Hallo Tino,

bekomms irgendiwe nicht zum Laufen....(keine Reaktion)
Der Code läuft aber bis zum Ende durch da ich am Ende den Blattschutz aktiviert habe und beim nächsten Start die Fehlermeldung bekam.

Da ich die Tabelle erst neu aufbaue ist es eigentlich ausgeschlossen dass mehrere Duplikate vorhanden sind. Nachher wird dies ja ohnehin durch den Code unterbunden.

Zur Info: Tabelle dient dazu diverse Artikel auszubuchen und um zu verhindern dass ein Artikel doppelt verbucht wird (selbe Menge, selbe Auftragsnummer,...) sollte dieser Code her.


Vielleicht hast eine Idee warums bei mir ohne Änderungen durchläuft.


SG und schönes Wochenende
ToS2


  

Betrifft: kannst Du ein Beispiel hochladen?... von: Tino
Geschrieben am: 21.11.2014 20:35:54

Hallo,
wenn Du einen Blattschutz hast muss dieser vorher aufgehoben und nach Ablauf wieder gesetzt werden.
Kannst Du ein Bsp. hochladen wo keine Änderung erfolgt obwohl diese erfolgen müsste?

Gruß Tino


  

Betrifft: ist nicht von mir! von: Tino
Geschrieben am: 21.11.2014 20:31:44

Hallo,
dies ist ein Add-In aber nicht von mir entwickelt.

Stammt von hier, aber wie es aussieht ist diese Seite Tod!


Hier das Add-in als Zip-File
https://www.herber.de/bbs/user/93950.zip


Gruß Tino


  

Betrifft: Herzlichen Dank Tino . owT von: Matze Matthias
Geschrieben am: 21.11.2014 21:02:59




  

Betrifft: AW: Herzlichen Dank Tino . owT von: ToS2
Geschrieben am: 21.11.2014 21:23:34

Hallo Tino,

Blattschutz hab ich bei meiner Tabelle rausgenommen.
Anbei die Testmappe.




https://www.herber.de/bbs/user/93953.xls


  

Betrifft: Code angepasst von: Tino
Geschrieben am: 21.11.2014 21:41:12

Hallo,
ok. habe den Code auf Deine Tabelle angepasst.

Sub start()

Dim rngRef As Range, rngData As Range, rngTmp As Range
Dim sVerkettenFormel$, n&


With Tabelle1 'Tabelle anpassen 
    'Ref 
    
    Set rngRef = .Range("A2:I2")
    'Datenbereich 
    Set rngData = Range("A7", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, rngRef.Columns.Count)
    If rngData.Rows(1).Row < 7 Then Exit Sub
    'letzte Spalte als Hilfsspalte 
    Set rngTmp = .Cells(rngData.Rows(1).Row, .Columns.Count).Resize(rngData.Rows.Count)
End With

'Formel zum verketten 
For n = 1 To rngRef.Columns.Count
    sVerkettenFormel = sVerkettenFormel & "RC" & rngRef.Cells(1, n).Column & "&"
Next n
sVerkettenFormel = Left$(sVerkettenFormel, Len(sVerkettenFormel) - 1)


With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
        
       
        'Formel Zeile 1 
        .Cells(rngRef.Rows(1).Row, .Columns.Count).FormulaR1C1 = "=" & sVerkettenFormel
        'Formel Zeilen Datenbereich 
        rngTmp.FormulaR1C1 = "=IF(R" & rngRef.Rows(1).Row & "C=" & sVerkettenFormel & ",TRUE,ROW())"
        .Parent.Calculate
        'Sortieren 
        rngTmp.EntireRow.Sort rngTmp.Cells(1, 1), Order1:=xlAscending, Header:=xlNo
        'Formelergebnis Wahr vorhanden? 
        If Application.WorksheetFunction.CountIf(rngTmp, True) > 0 Then
            'lösche Zeilen mit Formelergebnis Wahr 
            rngTmp.SpecialCells(xlCellTypeFormulas, 4).EntireRow.Delete
        End If
        'Hilfspalte löschen 
        rngTmp.EntireColumn.Delete
    
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    
End With
End Sub
Gruß Tino


  

Betrifft: AW: Code angepasst von: ToS2
Geschrieben am: 24.11.2014 11:57:17

Danke Tino,

funktioniert soweit mal super!!!
werd mich jetzt noch ein wenig durch die Foren wursteln um das mit der Zeilenausgabe hinzubekommen.

SG und danke nochmals
ToS2


  

Betrifft: Allerdings reagiert die ForumsSoftware auf ... von: Luc:-?
Geschrieben am: 21.11.2014 21:20:51

…so etwas nicht mit dem Setzen des Code-Symbols zum Betreff des angezeigten Thread-Baums, Matze,
weshalb ich das im Ggsatz zu Tab-HTML-Darstellungen nur für eine Spielerei halte…
Gruß, Luc :-?


 

Beiträge aus den Excel-Beispielen zum Thema "Duplikate anzeigen/löschen"