Code-Optimierung: Suche sehr langsam

Sub SuchenLAAANGSAMMM() For t = 1 To 2000 Wert = Worksheets("Tabelle1").Cells(t, 1) For w = 1 To 500 Vergleich = Worksheets("Tabelle2").Cells(w, 1) If Wert = Vergleich Then Worksheets("Tabelle1").Cells(t, 3) = "Gefunden" If Wert = Vergleich Then If Worksheets("Tabelle1").Cells(t, 2) <> Worksheets("Tabelle2").Cells(w, 2) Then Worksheets("Tabelle2").Cells(w, 3) = "Fehler!" Next w ' Fehlermeldung, wenn Wert aus Tabelle1 nicht in Tabelle2 gefunden If Worksheets("Tabelle1").Cells(t, 3) <> "Gefunden" Then Worksheets("Tabelle1").Cells(t, 3) = "Nicht gefunden" Next t End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
Beide Code's in ein neues Modul und dann mal vergleichen
Option Explicit

Private Declare Function GetTickCount Lib "kernel32" () As Long

Sub SuchenLAAANGSAMMM()
    'Original etwas übersichtlicher dargestellt
    'Eine IF-Prüfung weniger
    Dim prcStart As Long, prcEnd As Long
    prcStart = GetTickCount
    Dim t As Long, w As Long
    Dim Wert As Variant, Vergleich As Variant
    For t = 1 To 2000
        Wert = Worksheets("Tabelle1").Cells(t, 1)
        For w = 1 To 500
            Vergleich = Worksheets("Tabelle2").Cells(w, 1)
            If Wert = Vergleich Then
                Worksheets("Tabelle1").Cells(t, 3) = "Gefunden"
                If Worksheets("Tabelle1").Cells(t, 2) <> Worksheets("Tabelle2").Cells(w, 2) Then
                    Worksheets("Tabelle2").Cells(w, 3) = "Fehler!"
                End If
            End If
        Next w
        ' Fehlermeldung, wenn Wert aus Tabelle1 nicht in Tabelle2 gefunden
        If Worksheets("Tabelle1").Cells(t, 3) <> "Gefunden" Then Worksheets("Tabelle1").Cells(t, 3) = "Nicht gefunden"
    Next t
    prcEnd = GetTickCount
    MsgBox "Dauer Langsam: " & prcEnd - prcStart
End Sub

Sub Suchen_Schnell()
    'by Ramses
    Dim prcStart As Long, prcEnd As Long
    prcStart = GetTickCount
    Dim Wert As Variant
    Dim i As Integer
    Dim qWks As Worksheet
    Dim tarWks As Range, tarRng As Range, findRng As Range
    Set qWks = Worksheets("Tabelle1")
    Set tarWks = Worksheets("Tabelle2")
    Set tarRng = tarWks.Range("A1:A500")
    For i = 1 To 2000
        Wert = qWks.Cells(i, 1)
        With tarRng
            On Error Resume Next
            Set findRng = .Find(Wert, LookIn:=xlValues)
            If findRng Is Nothing Then
                qWks.Cells(i, 3) = "Gefunden"
                If qWks.Cells(i, 2) <> tarRng.Offset(0, 1) Then
                    tarRng.Offset(0, 3) = "Fehler!"
                End If
            End If
            On Error GoTo 0
        End With
    Next i
    Set qWks = Nothing
    Set tarWks = Nothing
    Set tarRng = Nothing
    Set findRng = Nothing
    prcEnd = GetTickCount
    MsgBox "Dauer Langsam: " & prcEnd - prcStart
End Sub

Gruss Rainer

Hallo
Achim hatte da noch eine gute Idee.
Mal probieren,... ich hoffe ich habs richtig umgesetzt
Sub Suchen_Schnell_modified()
    'by Ramses
    Dim prcStart As Long, prcEnd As Long
    prcStart = GetTickCount
    Dim Wert As Variant
    Dim i As Integer
    Dim qWks As Worksheet
    Dim tarWks As Range, tarRng As Range, findRng As Range
    Set qWks = Worksheets("Tabelle2")
    Set tarWks = Worksheets("Tabelle1")
    Set tarRng = tarWks.Range("A1:A2000")
    For i = 1 To 500
        Wert = qWks.Cells(i, 1)
        With tarRng
            On Error Resume Next
            Set findRng = .Find(Wert, LookIn:=xlValues)
            If findRng Is Nothing Then
                tarRng.Offset(0, 2) = "Gefunden"
                If tarRng.Offset(0, 1) <> qWks.Cells(i, 2) Then
                    qWks.Cells(i, 3) = "Fehler!"
                End If
            End If
            On Error GoTo 0
        End With
    Next i
    Set qWks = Nothing
    Set tarWks = Nothing
    Set tarRng = Nothing
    Set findRng = Nothing
    prcEnd = GetTickCount
    MsgBox "Dauer schnell modified: " & prcEnd - prcStart
End Sub

Gruss Rainer

Sub SortierenSchneller() '...Dim Deklarationen Application.ScreenUpdating = False Application.Calculation = xlCalculationManual '.... Der Code (von Dir oder besser von Ramses) Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

Code-Optimierung: Suche sehr langsam

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

286 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Code-Optimierung: Suche sehr langsam

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

286 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread