For loop very bad performance

[bydo]

Hello,


I am matching about 22,000 IDs with a 55,000 row huge inventory. On hit I will check another column for a value and write down the findings in a third table.


My problem is, that this procedure will take more than 20 minutes (I canceled it there). Why is it taking so long and how can I improve the performance?


An exemplary table with code is enclosed, thanks in advance and regards


Bydo

[Bob Phillips]

Try this

Public Sub FormatOutput()
Dim lastrow As Long
        
    Application.ScreenUpdating = False

    lastrow = Worksheets("Prüfliste").Range("A" & Rows.Count).End(xlUp).Row
    With Worksheets("Ausgabe")
    
        .Range("A2").Resize(lastrow - 1).FormulaR1C1 = "=Prüfliste!RC"
        .Range("B2").Resize(lastrow - 1).Value = Format(Now, "DD.MM.YYYY HH:MM")
        .Range("C2").Resize(lastrow - 1).Value = "bydo@vba.ms"
        .Range("D2").Resize(lastrow - 1).Value = "bydo"
        .Range("E2").Resize(lastrow - 1).FormulaR1C1 = _
        "=IF(ISNA(MATCH(Prüfliste!RC[-3],Inventar!C[-2],0)),MATCH(Prüfliste!RC[-3],Inventar!C[-1],0),MATCH(Prüfliste!RC[-3],Inventar!C[-2],0))"
        .Range("F2").Resize(lastrow - 1).FormulaR1C1 = _
            "=IF(ISNA(RC5),""nicht gefunden"",IF(OR(INDEX(Inventar!C6,RC5)=""aktiv"",INDEX(Inventar!C6,RC5)=""wartend""),"""",INDEX(Inventar!C[-4],RC5)))"
        .Range("G2").Resize(lastrow - 1).FormulaR1C1 = _
            "=IF(ISNA(RC5),""nicht gefunden"",IF(OR(INDEX(Inventar!C6,RC5)=""aktiv"",INDEX(Inventar!C6,RC5)=""wartend""),"""",INDEX(Inventar!C[-2],RC5)))"
        .Range("H2").Resize(lastrow - 1).FormulaR1C1 = _
            "=IF(ISNA(RC5),""nicht gefunden"",IF(OR(INDEX(Inventar!C6,RC5)=""aktiv"",INDEX(Inventar!C6,RC5)=""wartend""),"""",INDEX(Inventar!C[-2],RC5)))"
            
        With .Range("A2").Resize(lastrow - 1, 8)
        
            .Value = .Value
        End With
        
        .Columns("E:E").Delete
    End With
        
    Application.ScreenUpdating = True
End Sub

[SamT]

The Code from your attachement:

Sub FORIFIF()
Dim CHECKROW As Long
Dim INVENTROW As Long
Dim OUTPUTROW As Long
        
Application.ScreenUpdating = False

OUTPUTROW = 1

    For CHECKROW = Sheets("Prüfliste").Range("A" & Rows.Count).End(3)(1).Row To 2 Step -1
        OUTPUTROW = OUTPUTROW + 1
        Sheets("Ausgabe").Cells(OUTPUTROW, 1).Value = Sheets("Prüfliste").Cells(CHECKROW, 1).Value
        Sheets("Ausgabe").Cells(OUTPUTROW, 2).Value = Format(Now, "DD.MM.YYYY HH:MM")
        Sheets("Ausgabe").Cells(OUTPUTROW, 3).Value = "bydo@vba.ms"
        Sheets("Ausgabe").Cells(OUTPUTROW, 4).Value = "bydo"
            For INVENTROW = Sheets("Inventar").Range("A" & Rows.Count).End(3)(1).Row To 2 Step -1
                If Sheets("Inventar").Cells(INVENTROW, 3).Value = Sheets("Prüfliste").Cells(CHECKROW, 2).Value Then
                    If Sheets("Inventar").Cells(INVENTROW, 6).Value = "aktiv" Or Sheets("Inventar").Cells(INVENTROW, 6).Value = "wartend" Then
                        Exit For
                    Else
                        Sheets("Ausgabe").Cells(OUTPUTROW, 5).Value = Sheets("Inventar").Cells(INVENTROW, 2).Value
                        Sheets("Ausgabe").Cells(OUTPUTROW, 6).Value = Sheets("Inventar").Cells(INVENTROW, 5).Value
                        Sheets("Ausgabe").Cells(OUTPUTROW, 7).Value = Sheets("Inventar").Cells(INVENTROW, 6).Value
                        Exit For
                    End If
                End If
                If Sheets("Inventar").Cells(INVENTROW, 4).Value = Sheets("Prüfliste").Cells(CHECKROW, 2).Value Then
                    If Sheets("Inventar").Cells(INVENTROW, 6).Value = "aktiv" Or Sheets("Inventar").Cells(INVENTROW, 6).Value = "wartend" Then
                        Exit For
                    Else
                        Sheets("Ausgabe").Cells(OUTPUTROW, 5).Value = Sheets("Inventar").Cells(INVENTROW, 2).Value
                        Sheets("Ausgabe").Cells(OUTPUTROW, 6).Value = Sheets("Inventar").Cells(INVENTROW, 5).Value
                        Sheets("Ausgabe").Cells(OUTPUTROW, 7).Value = Sheets("Inventar").Cells(INVENTROW, 6).Value
                        Exit For
                    End If
                End If
                If INVENTROW = 2 Then
                        Sheets("Ausgabe").Cells(OUTPUTROW, 5).Value = "nicht gefunden"
                        Sheets("Ausgabe").Cells(OUTPUTROW, 6).Value = "nicht gefunden"
                        Sheets("Ausgabe").Cells(OUTPUTROW, 7).Value = "nicht gefunden"
                End If
            Next INVENTROW
    Next CHECKROW
    
    Application.ScreenUpdating = True
    
End Sub

I think we can make that 5500 times faster

[SamT]

Here's what I came up with

Sub FORIFIF()
Dim CheckRow As Long
Dim OutRow As Long
Dim Ausgabe As Object
Dim Inventar As Object
Dim Prüfliste As Object
Dim InventCallSigns As Range
Dim Found As Range

Set Prüfliste = Sheets("Prüfliste")
Set Inventar = Sheets("Inventar")
Set Ausgabe = Sheets("Ausgabe")
Set InventCallSigns = Inventar.Range("C:D")
OutRow = 1
        
Application.ScreenUpdating = False

  For CheckRow = Prüfliste.Range("A" & Rows.Count).End(3)(1).Row To 2 Step -1
    Ausgabe.Cells(OutRow, 1).Value = Prüfliste.Cells(CheckRow, 1).Value
    Ausgabe.Cells(OutRow, 2).Value = Format(Now, "DD.MM.YYYY HH:MM")
    Ausgabe.Cells(OutRow, 3).Value = "bydo@vba.ms"
    Ausgabe.Cells(OutRow, 4).Value = "bydo"

    OutRow = OutRow + 1

    Set Found = InventCallSigns.Find(Prüfliste.Cells(CheckRow, 2))
      If Found Is Nothing Then
        Ausgabe.Cells(OutRow, 5).Value = "nicht gefunden"
        Ausgabe.Cells(OutRow, 6).Value = "nicht gefunden"
        Ausgabe.Cells(OutRow, 7).Value = "nicht gefunden"
      Else
        With Inventar.Rows(Found.Row)
          If .Cells(6) <> "aktiv" And .Cells(6) <> "wartend" Then
            Ausgabe.Cells(OutRow, 5).Value = .Cells(2).Value
            Ausgabe.Cells(OutRow, 6).Value = .Cells(5).Value
            Ausgabe.Cells(OutRow, 7).Value = .Cells(6).Value
          End If
        End With
      End If
    Next CheckRow
  Application.ScreenUpdating = True
End Sub

[snb]

oder:

Sub M_snb()
   sn = Sheets("inventar").Cells(1).CurrentRegion
   sp = Sheets("prüfliste").Cells(1).CurrentRegion
   Set d_01 = CreateObject("scripting.dictionary")
   
   With CreateObject("scripting.dictionary")
     For j = 2 To UBound(sn)
        x0 = .Item(sn(j, 4))
     Next
     
     For j = 2 To UBound(sp)
        If .exists(sp(j, 2)) Then d_01.Item(sp(j, 1)) = Array(sp(j, 1), Format(Now, "DD.MM.YYYY HH:MM"), "bydo@vba.ms", "bydo")
     Next
   End With
   
   If d_01.Count > 0 Then Sheets("ausgabe").Cells(2, 1).Resize(d_01.Count, 4) = Application.Index(d_01.items, 0, 0)
End Sub

[bydo]

Outstanding work xld,
The final result clocked in at 2 minutes 30 seconds, thanks a lot for your help!!
Mind if you tell me why your method is so much faster? What did you actually do?

Thanks a lot for your input also SamT,
your code took 8 minutes to work the lists!

[snb]

Crossposted in ca. 20 Fora:

http://www.clever-excel-forum.de/Thr...80109#pid80109

[Zack Barresse]

bydo, please read this.

http://www.excelguru.ca/content.php?184

There are ways to cross-post, and there are ways to not. Please do not waste our members time.

[Bob Phillips]

Outstanding work xld,
The final result clocked in at 2 minutes 30 seconds, thanks a lot for your help!!
Mind if you tell me why your method is so much faster? What did you actually do?

My approach was to remove all of the loops, which is what takes all of the time. Instead, I setup each column with formulae that emulated your VBA logic. I then did a copy-pastevalues of them all. I did insert a column that you didn't want to get the row n umber which I used within those formulae, so I had to delete that at the end.