Hallo,
bräuchte eure Hilfe um den folgenden Code zu verstehen. Weil der Code mir 192 Duplikate anzeigt obwohl in der Liste nur 1 da ist. Ich habe herausgefunden, dass das mit der Zeile zu tun hat und habe statt 256, 13834 ersetzt und ich habe nachvollziehbare Zahlen angezeigt bekommen. Aber wieso ist das so?
Die Zeile verstehe ich auch nicht: lngMaxArrays = lngZeilenBereich / 50
Und eine letzte Sache wäre, wie müsste ich den Code ändern, damit ich den Bereich nicht markieren müsste, sondern ein voreingestellter Bereich im Code stehen würde. Also von Spalte A bis K, bis zur letzten gefüllten Zeile?
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)))
Hier der Code:
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