Office: Makro dauert ewig ? warum?

ArnolPe · 26. Juni 2016

Hallo zusammen,
ich benötige bitte Hilfe bei einem Makro, das soll auf doppelte Einträge prüfen und diese dann Rot markieren.
Hat man nur wenige (50) Zeilen so läuft das Script ruck zuck ohne Problme durch, sind es jedoch mal mehrere Einträge hängt es sich auf (Excl, keine Rückmeldung) bzw. läuft ewig bis es fertig ist. Es kommt keine Fehlermeldung oder Abbruch? Schon mal vielen Dank
Grüße
Peter

Code:

Sub zellen_mit_doppelten_einträgen_suchen_und_markieren()

On Error Resume Next

Dim Spalten As Object
Dim zelle1 As Object
Dim zelle2 As Object
Dim F As Integer
Dim x As Long, i As Long, y As Long, z As Long
Dim eing
F = 0
Set zelle1 = Selection.SpecialCells(xlLastCell).Offset(1, 1)
Set zelle2 = Selection.SpecialCells(xlLastCell)
eing = InputBox("Geben Sie bitte die Spalte ein ab wo auf doppelte Werte geprüft werden soll z.B. C2 oder E5", "Excel, (c) Blabla_2016")
Range(eing).Select
Set Spalten = ActiveCell.CurrentRegion
eing = ""
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
zelle1 = ActiveCell
ActiveCell.Offset(1).Select
For x = 1 To Spalten.Rows.Count
If ActiveCell.Value = zelle1 Then
If ActiveCell "" Then
ActiveCell.Interior.ColorIndex = 5
End If
End If
ActiveCell.Offset(1).Select
Next x
For i = 1 To Spalten.Rows.Count - 1
For z = 1 To Spalten.Rows.Count
ActiveCell.Offset(-1).Select
Next z
F = F + 1
zelle1.Clear
zelle2 = ActiveCell
ActiveCell.Offset(1).Select
For y = 1 To Spalten.Rows.Count
If ActiveCell.Value = zelle2 Then
If ActiveCell "" And Selection.Interior.ColorIndex = xlNone Then
ActiveCell.Interior.ColorIndex = 3
End If
End If
ActiveCell.Offset(1).Select
Next y
Next i
zelle2.Clear
'** Ursprungszustand wieder herstellen
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

Range("A1").Select

Dim strText As String
strText = "ACHTUNG >> keine Rote Marierung? auch keine doppelten :-) !!!"
msgbox "Sie können nun die doppelten Einträge / Werte überprüfen, diese sind alle ROT markiert, " & strText, 64, "Excel , (c) Blabla_2016"

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

:)

EarlFred · 27. Juni 2016

Hallo Peter,

magst Du mal nach fertigen Scripten suchen? Es gibt sicher genügend im Netz zu finden.

Grüße
EarlFred

xlph · 27. Juni 2016

Kannst du die zugehörige Datei hochladen?

xlph · 27. Juni 2016

Das dürfte um einiges schneller sein.

Code:

Sub XLPH_zellen_mit_doppelten_einträgen_suchen_und_markieren()

Dim strStartCellAddress As String
Dim rngStartCell As Range
Dim rngData As Range

Dim lngIndex As Long
Dim vntItem As Variant
Dim colUnique As Collection
Dim vntValueFirst As Variant

Dim strText As String

Do
strStartCellAddress = InputBox("Geben Sie bitte eine Zelladresse der Spalte ein, ab wo auf doppelte Werte geprüft werden soll z.B. C2 oder E5", "Excel, (c) Blabla_2016", ActiveCell.Address(0, 0))
If StrPtr(strStartCellAddress) = 0 Then Exit Sub
Set rngStartCell = GetCell(ActiveSheet, strStartCellAddress)
If rngStartCell Is Nothing Then
MsgBox "Die eingegebene Zell-Adresse ist ungültig!"
Else
Exit Do
End If
Loop

With rngStartCell
Set rngData = .Worksheet.Cells(.Row, .Column).Resize((.CurrentRegion.Row + .CurrentRegion.Rows.Count - 1) - (.Row - 1))
End With
Set rngStartCell = Nothing

Set colUnique = New Collection

With rngData

For Each vntItem In .Value
lngIndex = lngIndex + 1
If lngIndex = 1 Then
vntValueFirst = vntItem
Else
If vntItem = vntValueFirst Then
.Cells(lngIndex).Interior.Color = vbBlue
Else
If CollectionKeyExist(colUnique, CStr(vntItem)) Then
.Cells(lngIndex).Interior.Color = vbRed
Else
colUnique.Add 0, CStr(vntItem)
End If
End If
End If
Next

End With

Set colUnique = Nothing
Set rngData = Nothing

strText = "ACHTUNG >> keine Rote Marierung? auch keine doppelten :-) !!!"
MsgBox "Sie können nun die doppelten Einträge / Werte überprüfen, diese sind alle ROT markiert, " & strText, 64, "Excel , (c) Blabla_2016"

End Sub

Private Function GetCell(ByRef wks As Worksheet, ByVal strCellAddress As String) As Range
With wks
On Error Resume Next
Set GetCell = .Range(strCellAddress)
On Error GoTo 0
If Not GetCell Is Nothing Then
Set GetCell = GetCell.Cells(1)
End If
End With
End Function

Private Function CollectionKeyExist(ByRef colData As Collection, ByVal strKey As String) As Boolean
On Error Resume Next
CollectionKeyExist = (VarType(colData(strKey)) > -1)
On Error GoTo 0
End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

ArnolPe · 27. Juni 2016

Wow.. Tausend und ein dank, das läuft jetzt Turbo!!! *Smilie *Smilie

Kannst du mir noch bitte veraten wo ich den Knopf hatte? also was macht es jetzt schneller?

Grüße

Peter

RPP63 · 27. Juni 2016

Hallo Peter!

Online - Excel Programmierung VBA Makro: Performance (2) - Select Activate Bremsen und ein Beispiel

Gruß Ralf

xlph · 27. Juni 2016

Dein Code ist fürs Bremsen optimiert.*wink.gif*

Dann fangen wir mal mit der größten Bremse an...

1. Select / Activate: Zellen können direkt angesprochen werden, ohne sie vorher auswählen zu müssen.

2. Algorithmus entwickeln der doppelte Durchläufe vermeidet

3. Nur Schleifen einsetzen, die nötig sind

4. Array-Verarbeitung ist viel schneller als Zell-Verarbeitung

5. Prüfung auf Doppelungen bspw. Collection oder Dictionary benutzen statt weitere Schleifen

Bitte das Lesen: Performance (1-4)

ArnolPe · 28. Juni 2016

:-( oh je oh je... Danke da muss ich wohl noch viel lernen, aber mächtig aufschlußreich zu lesen....

Office: Makro dauert ewig ? warum?

Makro dauert ewig ? warum?

Makro dauert ewig ? warum?

Makro dauert ewig ? warum?

Makro dauert ewig ? warum?

Makro dauert ewig ? warum? - Similar Threads - Makro dauert ewig

Name der Datei durch Excel geändert

Ein Makro für mehrere Register

Makro öffnet unerwartete Datei

Leerzeilen entfernen

Makro Schaltflaechen vervielfaeltigen sich....

Seit Win 11 Zugriffsprobleme bei Excel über Makros

Makro dauert sehr lange