Spalten-Einmaligkeitsprüfung zu langsam

Sub Einmaligkeit_Ueberpruefen_Spalte_B() Dim Cell As Range Dim z As Range Dim check As Long check = 0 ' Loop über alle Zellen der 2. Spalte (B) im aktiven Sheet For Each z In ActiveSheet.UsedRange.Columns(2).Cells ' nur überprüfen, wenn die Zelle nicht leer ist If Not z.Value = "" Then ' jede zeile von z aus überprüfen auf Wert in Spalte B For Each Cell In ActiveSheet.Range(z, z.End(xlDown)).Cells ' Wert Vergleichen: Zelle vom 1. Loop und Zelle vom momentanen If Range("B" & Cell.Row).Value = z.Value Then check = check + 1 If Not Cell.Row = z.Row Then Range("I" & z.Row).Value = Range("I" & z.Row).Value & " " & Cell.Row End If Next If check > 1 Then z.Interior.ColorIndex = 3 ElseIf z.Interior.ColorIndex = 3 Then z.Interior.ColorIndex = xlNone End If check = 0 Else Exit For End If Next z MsgBox "Überprüfung der Spalte B abgeschlossen!" End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Einmaligkeit_Ueberpruefen_Spalte_B() Dim Cell As Range Dim z As Range Dim check As Long check = 0 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' Loop über alle Zellen der 2. Spalte (B) im aktiven Sheet For Each z In ActiveSheet.UsedRange.Columns(2).Cells ' nur überprüfen, wenn die Zelle nicht leer ist If Not z.Value = "" Then ' jede zeile von z aus überprüfen auf Wert in Spalte B For Each Cell In ActiveSheet.Range(z, z.End(xlDown)).Cells ' Wert Vergleichen: Zelle vom 1. Loop und Zelle vom momentanen If Range("B" & Cell.Row).Value = z.Value Then check = check + 1 If Not Cell.Row = z.Row Then Range("I" & z.Row).Value = Range("I" & z.Row).Value & " " & Cell.Row End If Next If check > 1 Then z.Interior.ColorIndex = 3 ElseIf z.Interior.ColorIndex = 3 Then z.Interior.ColorIndex = xlNone End If check = 0 Else Exit For End If Next z Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.Calculate MsgBox "Überprüfung der Spalte B abgeschlossen!" End Sub

Sub Einmaligkeit_Ueberpruefen_Spalte_B() Dim Cell As Range Dim z As Range Dim check As Long check = 0 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' Loop über alle Zellen der 2. Spalte (B) im aktiven Sheet For Each z In ActiveSheet.UsedRange.Columns(2).Cells ' nur überprüfen, wenn die Zelle nicht leer ist If z.Value <> "" Then ' jede zeile von z aus überprüfen auf Wert in Spalte B For Each Cell In ActiveSheet.Range(z, z.End(xlDown)).Cells ' Wert Vergleichen: Zelle vom 1. Loop und Zelle vom momentanen If Range("B" & Cell.Row).Value = z.Value Then check = check + 1 If Cell.Row <> z.Row Then Range("I" & z.Row).Value = Range("I" & z.Row).Value & " " & Cell.Row End If Next If check > 1 Then z.Interior.ColorIndex = 3 ElseIf z.Interior.ColorIndex = 3 Then z.Interior.ColorIndex = xlNone End If check = 0 Else Exit For End If Next z Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.Calculate MsgBox "Überprüfung der Spalte B abgeschlossen!" End Sub

Function GetTickCount Lib "kernel32" () As Long Public lngTime As Long Sub Einmaligkeit_Ueberpruefen_Spalte_B() Dim Cell As Range Dim z As Range Dim check As Long, lngLastRow As Long check = 0 lngTime = GetTickCount lngLastRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' Loop über alle Zellen der 2. Spalte (B) im aktiven Sheet ' For Each z In ActiveSheet.UsedRange.Columns(2).Cells For Each z In ActiveSheet.Range("B1:B" & lngLastRow) ' nur überprüfen, wenn die Zelle nicht leer ist If Not z.Value = "" Then ' jede zeile von z aus überprüfen auf Wert in Spalte B 'For Each Cell In ActiveSheet.Range(z, z.End(xlDown)).Cells For Each Cell In ActiveSheet.Range("B" & z.Row & ":B" & lngLastRow) ' Wert Vergleichen: Zelle vom 1. Loop und Zelle vom momentanen If Range("B" & Cell.Row).Value = z.Value Then check = check + 1 If Not Cell.Row = z.Row Then Range("I" & z.Row).Value = Range("I" & z.Row).Value & " " & Cell.Row End If Next If check > 1 Then z.Interior.ColorIndex = 3 ElseIf z.Interior.ColorIndex = 3 Then z.Interior.ColorIndex = xlNone End If check = 0 Else Exit For End If Next z Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.Calculate MsgBox "Zeit = " & GetTickCount - lngTime End Sub Gruß Heiko PS: Rückmeldung wäre nett !

Function GetTickCount Lib "kernel32" () As Long Public lngTime As Long Sub Einmaligkeit_Ueberpruefen_Spalte_B() Dim rngZ As Range, rngFind As Range, rngFirstAddress Dim lngCheck As Long, lngLastRow As Long lngCheck = 0 lngTime = GetTickCount lngLastRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' Loop über alle Zellen der 2. Spalte (B) im aktiven Sheet ' For Each rngZ In ActiveSheet.UsedRange.Columns(2).Cells For Each rngZ In ActiveSheet.Range("B1:B" & lngLastRow) ' nur überprüfen, wenn die Zelle nicht leer ist If rngZ.Value <> "" Then Set rngFind = ActiveSheet.Range("B" & rngZ.Row & ":B" & lngLastRow).Find(rngZ.Value, LookAt:=xlWhole, LookIn:=xlValues) If Not rngFind Is Nothing Then rngFirstAddress = rngFind.Address Do lngCheck = lngCheck + 1 If rngFind.Row <> rngZ.Row Then ActiveSheet.Range("H" & rngZ.Row).Value = ActiveSheet.Range("H" & rngZ.Row).Value & " " & rngFind.Row Set rngFind = ActiveSheet.Range("B" & rngZ.Row & ":B" & lngLastRow).FindNext(rngFind) Loop While Not rngFind Is Nothing And rngFind.Address <> rngFirstAddress End If If lngCheck > 1 Then rngZ.Interior.ColorIndex = 3 ElseIf rngZ.Interior.ColorIndex = 3 Then rngZ.Interior.ColorIndex = xlNone End If lngCheck = 0 Else Exit For End If Next rngZ Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.Calculate MsgBox "Zeit = " & GetTickCount - lngTime End Sub Gruß Heiko PS: Rückmeldung wäre nett !

Hi Heiko
seltsam.. ich bin sicher, dass ich ne Antwort geschrieben hab.
Womöglich hab ich die Antwort der falschen Person oder so geschrieben.. peinlich
Die neue Version ist nun 14 Minuten gelaufen. Hab es nun abgebrochen.
Denn inzwischen hab ich es anders gelöst, habe das eigentlich im "verschwundenen" Post schon geschrieben. Tut mir leid, dass du nun unnötigen Aufwand hattest. Meine neue Version liest die Spalte in ein Array ein, sortiert das Array, vegleicht jeden Index mit dem nächsten und wenn die gleich sind, wird das in ein zweites Array geschrieben. am Schluss geh ich nochmal die ganze Spalte durch und markiere jede Zelle rot, die mit einem Eintrag im 2. array übereinstimmt.
Auf diese Weise geht es viel schneller, nämlich nur ca. 10 Sekunden. Jetzt muss ich nur noch herausfinden, wie ich die Funktion automatisch beim speichern ausführen kann. (Da sollte sie schon nicht gerade 20 minuten haben ;))
Aber vielmals Danke für deine Mühe. Du warst, soweit ich mich erinnere, auch derjenige, der mir beim letzten VB-Problem geholfen hat.
Gruss David
noch mein neuer code, falls er dich interessieren sollte:


Sub Einmaligkeit_Ueberpruefen_Spalte_B()
Dim z As Range
Dim iRows As Integer
iRows = ActiveSheet.Columns(2).End(xlDown).Row
Dim bCheck As Boolean
bCheck = True
' Array mit Feldzahl = Zeilenzahl
Dim aSpalte() As String
ReDim Preserve aSpalte(iRows)
Dim sTemp As String
' Loop über alle Zellen der 2. Spalte (B) im aktiven Sheet
For Each z In ActiveSheet.UsedRange.Columns(2).Cells
'farben zurücksetzen
z.Interior.ColorIndex = xlNone
' nur überprüfen, wenn die Zelle nicht leer ist
If z.Value <> "" Then
' Zeile ins Array speichern
aSpalte(z.Row - 1) = z.Value
Else
Exit For
End If
Next z
Dim i As Integer
While bCheck
bCheck = False
For i = 0 To iRows - 1
If aSpalte(i) > aSpalte(i + 1) Then
sTemp = aSpalte(i)
aSpalte(i) = aSpalte(i + 1)
aSpalte(i + 1) = sTemp
bCheck = True
End If
Next
Wend
Dim sDouble As String
sDouble = ""
Dim aDouble() As String
Dim iSizeOfDoubleArray As Integer
iTemp = 0
' Doppelte in den String und in den Array füllen
For i = 0 To iRows - 1
If aSpalte(i) = aSpalte(i + 1) Then
' array vergrössern und doppelte Zahl hineinfüllen
iSizeOfDoubleArray = iSizeOfDoubleArray + 1
ReDim Preserve aDouble(iSizeOfDoubleArray)
aDouble(iSizeOfDoubleArray - 1) = aSpalte(i)
' doppelte zahl in string schreiben
If sDouble = "" Then
sDouble = aSpalte(i)
Else
sDouble = sDouble & ", " & aSpalte(i)
End If
End If
Next
' Den Markierdurchlauf der Spalte nur starten, wenn's überhaupt was zu Markieren gibt
If iTemp <> 0 Then
For Each z In ActiveSheet.UsedRange.Columns(2).Cells
For i = 0 To iSizeOfDoubleArray - 1
If z.Value = aDouble(i) Then
z.Interior.ColorIndex = 3
End If
Next i
Next z
If iSizeOfDoubleArray = 1 Then
MsgBox "Nummer " & sDouble & " doppelt. Siehe rote Markierung"
Else
MsgBox "Nummern " & sDouble & " doppelt. Siehe rote Markierung"
End If
Else
MsgBox "Überprüfung der Spalte B abgeschlossen: Keine Doppelten!"
End If
End Sub

Sub Einmaligkeit_Spalte_B() Dim arrDaten() Dim lngRows As Long, lngI As Long, lngK As Long Dim strDoppelt As String Application.ScreenUpdating = False Application.Calculation = xlCalculationManual lngRows = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row arrDaten = Application.WorksheetFunction.Transpose(ActiveSheet.Range("B1:B" & lngRows)) For lngI = LBound(arrDaten) To UBound(arrDaten) For lngK = lngI + 1 To UBound(arrDaten) If arrDaten(lngI) = arrDaten(lngK) Then ActiveSheet.Cells(lngK, 2).Interior.ColorIndex = 3 If InStr(1, strDoppelt, " " & arrDaten(lngK) & " ") = 0 Then strDoppelt = strDoppelt & " " & arrDaten(lngK) & " " End If End If Next lngK Next lngI Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.Calculate If strDoppelt <> "" Then MsgBox "Nummer " & strDoppelt & " doppelt. Siehe rote Markierung", vbCritical Else MsgBox "Überprüfung der Spalte B abgeschlossen: Keine Doppelten!" End If End Sub

Sub EinmaligkeitOhneTranspose() Dim arrDaten Dim lngRows As Long, lngI As Long, lngK As Long Dim strDoppelt As String lngTime = GetTickCount Application.ScreenUpdating = False Application.Calculation = xlCalculationManual lngRows = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row arrDaten = ActiveSheet.Range("B1:B" & lngRows) For lngI = LBound(arrDaten) To UBound(arrDaten) For lngK = lngI + 1 To UBound(arrDaten) If arrDaten(lngI, 1) = arrDaten(lngK, 1) Then ActiveSheet.Cells(lngK, 2).Interior.ColorIndex = 3 If InStr(1, strDoppelt, " " & arrDaten(lngK, 1) & " ") = 0 Then strDoppelt = strDoppelt & " " & arrDaten(lngK, 1) & " " End If End If Next lngK Next lngI Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.Calculate MsgBox "Zeit = " & (GetTickCount - lngTime) / 1000 If strDoppelt <> "" Then MsgBox "Nummer " & strDoppelt & " doppelt. Siehe rote Markierung", vbCritical Else MsgBox "Überprüfung der Spalte B abgeschlossen: Keine Doppelten!" End If End Sub

Beliebteste Forumthreads (12 Monate)

Spalten-Einmaligkeitsprüfung zu langsam

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread