• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Count number of iterations in nested FOR loop

Ehtisham Ali

Ehtisham Ali

Member
Hi All,

I have a nested FOR loop, now I want to count number of total iterations and dynamically update it to a form Label.

iterations.jpg

As shown in the fig. above, total iterations are 144 and 72 is the number of current iteration.

Refer to the below code I am using:
Code: 
'n is number of rows in data
Total = n * n 'TOTAL ITERATIONS
For i = 2 To n
'SOMETHING
For j = i + 1 To n
'OTHERTHING
Next j
Next i
 
Hi Ali ,

You should run your code and see what you get.
Code: 
Public Sub temp()
          n = 17
          k = 1
          Total = n * n 'TOTAL ITERATIONS
         
          For i = 2 To n
'             SOMETHING
               For j = i + 1 To n
'                 OTHERTHING
                   Debug.Print i, j, k
                  k = k + 1
              Next j
          Next i
End Sub
Narayan
 
I have done with the code but it is taking too long to run when number of records in input file is near 6000, because it is running 6000*6000=36000000 times.

I am working on cols L, Q,R
Requirement:
Say for some “LINK DESCRIPTION”=ABC and (“DOWN TIME”, “UP TIME”) search if there exists any other “LINK DESCRIPTION”=ABC which occurred between “DOWN TIME” and “UP TIME”.
If YES color it RED else move to next.


Please find my attached code and suggest any way which can make it faster.

Attached ZIP file contains the main tool and rawdata which is input to the tool.

Please let me know if I have not explained well.
 

Attachments

  • ABG RAW Data - Search Duplicate Auto CI\'s.zip
    272.8 KB · Views: 0
Last edited:
Lots of time is spent writing to the userform. Lots. Reduce this by surrounding the label updating lines thus:
Code: 
    If inner Mod 1000 = 0 Then
      UserForm1.Label1.Caption = inner & " records searched out of total " & Total & " possible permutations"
      UserForm1.Label2.Caption = CI
    End If

I'll keep looking for more speed improvements.
 
Putting the data into memory (arrays) before looping speeds it up too.
The following gave a 24 fold increase in speed:
Code: 
Sub chkdupCI()
On Error GoTo Errhandler
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim Date1 As Date, Date2 As Date
Dim CI As String
Set ws = Sheets(1)
ws.Activate
n = Cells(Rows.Count, "B").End(xlUp).Row

With ws
  With .Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("L2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Range("Q2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Range("R2"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    .SetRange Range("A1:Z" & n)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With

  Total = (n - 1) * (n - 1)
  inner = 1
  CIArray = .Range("L2:L" & n)
  Date1Array = .Range("Q2:Q" & n)
  Date2Array = .Range("R2:R" & n)
  For i = 1 To UBound(CIArray)
    itrations = inner
    CI = CIArray(i, 1)
    Date1 = Date1Array(i, 1)
    Date2 = Date2Array(i, 1)
    For j = i + 1 To UBound(CIArray)
      inner = j + itrations
      DoEvents
      If inner Mod 10000 = 0 Then
        UserForm1.Label1.Caption = inner & " records searched out of total " & Total & " possible permutations"
        UserForm1.Label2.Caption = CI
      End If
      If CIArray(j, 1) = CI Then
        If Date1Array(j, 1) >= Date1 And Date2Array(j, 1) <= Date2 Then
          .Cells(j + 1, 1).Resize(, 26).Interior.Color = RGB(220, 0, 0)
        End If
      End If
    Next j
  Next i
End With
'Unload UserForm1
UserForm1.Label1.Caption = "All Duplicate CI's are highlighted in RED color."
UserForm1.Label2.Caption = "Report not saved !"
Errhandler:
Application.ScreenUpdating = True
End Sub
There are changes dotted about all over the place so copy/paste the lot rather than try to make changes to your existing macro.
 
You'll have to test this next possible timesaver against your other datasets and other routines.
Since you already sort the sheet, all column L values which are similar are adjacent, so we only need to compare within those small groups. This macro does this all in memory (save for colouring the rows) and while I get the same results as you with your sample dataset I also get a 1000 times increase in speed at worst, 1400 times at best. I suspect it's not necessary to update the labels on the userform while this is going on.
I'd like to know if it passes the test!
Code: 
Sub chkdupCI()
'On Error GoTo Errhandler
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim Date1 As Date, Date2 As Date
Dim CI As String
Set ws = Sheets(1)
ws.Activate
n = Cells(Rows.Count, "B").End(xlUp).Row

With ws
  With .Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("L2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Range("Q2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Range("R2"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    .SetRange Range("A1:Z" & n)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With

  CIArray = .Range("L2:L" & n)
  Date1Array = .Range("Q2:Q" & n)
  Date2Array = .Range("R2:R" & n)

  k = 1
  Do
    StartBlock = k
    LinkDesc = CIArray(k, 1)
    Do Until CIArray(k + 1, 1) <> LinkDesc
      k = k + 1
    Loop
    'Debug.Print StartBlock, k
    'here, process the block:
    'Range("L" & StartBlock + 1 & ":L" & k + 1).Select
    If k > StartBlock Then  'if more than one member:
      For i = StartBlock To k
        Date1 = Date1Array(i, 1)
        Date2 = Date2Array(i, 1)
        For j = i + 1 To k
          If Date1Array(j, 1) >= Date1 And Date2Array(j, 1) <= Date2 Then
            'Stop
            .Cells(j + 1, 1).Resize(, 26).Interior.Color = RGB(220, 0, 0)
          End If
        Next j
      Next i
    End If
    'end processing of block.
    k = k + 1
  Loop Until k >= UBound(CIArray)
End With
'Unload UserForm1
UserForm1.Label1.Caption = "All Duplicate CI's are highlighted in RED color."
UserForm1.Label2.Caption = "Report not saved !"
Errhandler:
Application.ScreenUpdating = True
End Sub
 
p45cal said:
You'll have to test this next possible timesaver against your other datasets and other routines.
Since you already sort the sheet, all column L values which are similar are adjacent, so we only need to compare within those small groups. This macro does this all in memory (save for colouring the rows) and while I get the same results as you with your sample dataset I also get a 1000 times increase in speed at worst, 1400 times at best. I suspect it's not necessary to update the labels on the userform while this is going on.
I'd like to know if it passes the test!
Code: 
Sub chkdupCI()
'On Error GoTo Errhandler
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim Date1 As Date, Date2 As Date
Dim CI As String
Set ws = Sheets(1)
ws.Activate
n = Cells(Rows.Count, "B").End(xlUp).Row
 
With ws
  With .Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("L2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Range("Q2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Range("R2"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    .SetRange Range("A1:Z" & n)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With
 
  CIArray = .Range("L2:L" & n)
  Date1Array = .Range("Q2:Q" & n)
  Date2Array = .Range("R2:R" & n)
 
  k = 1
  Do
    StartBlock = k
    LinkDesc = CIArray(k, 1)
    Do Until CIArray(k + 1, 1) <> LinkDesc
      k = k + 1
    Loop
    'Debug.Print StartBlock, k
    'here, process the block:
    'Range("L" & StartBlock + 1 & ":L" & k + 1).Select
    If k > StartBlock Then  'if more than one member:
      For i = StartBlock To k
        Date1 = Date1Array(i, 1)
        Date2 = Date2Array(i, 1)
        For j = i + 1 To k
          If Date1Array(j, 1) >= Date1 And Date2Array(j, 1) <= Date2 Then
            'Stop
            .Cells(j + 1, 1).Resize(, 26).Interior.Color = RGB(220, 0, 0)
          End If
        Next j
      Next i
    End If
    'end processing of block.
    k = k + 1
  Loop Until k >= UBound(CIArray)
End With
'Unload UserForm1
UserForm1.Label1.Caption = "All Duplicate CI's are highlighted in RED color."
UserForm1.Label2.Caption = "Report not saved !"
Errhandler:
Application.ScreenUpdating = True
End Sub
Click to expand...


thanks p45cal for all your replies. give me some time to test all your valuable solutions/suggestions. I will get back to you soon.
 
Hi p45cal

I am testing your the latest code, for the rawdata file I shared it is working lightning fast with no errors. But when I am trying to work on a actual 6426 records file it is throughing an "Script out of Range" error at last iteration.

Please refer to the screenshot of error.

debug.JPG
debuginfo.JPG

Any suggestions please.
 

Attachments

  • ABG_RAW_JULY-2015.xlsb
    408.4 KB · Views: 1
Yes, that's what testing is all about. See attached code, several tweaks as well, so again, copy the whole code.
Even with your 6.5k row file I don't think you need to update the user with progress information as it takes less than 1/3 seconds on my old machine to process it.
Test it again please.
Code: 
Sub chkdupCI()
Dim n As Long, CIArray, Date1Array, Date2Array, myLimit As Long, k As Long, StartBlock As Long, LinkDesc As String, i As Long, j As Long
'On Error GoTo Errhandler
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim Date1 As Date, Date2 As Date
Dim CI As String
Set ws = Sheets(1)
ws.Activate
n = Cells(Rows.Count, "B").End(xlUp).Row

With ws
  With .Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("L2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Range("Q2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Range("R2"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    .SetRange Range("A1:Z" & n)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With

  CIArray = .Range("L2:L" & n)
  Date1Array = .Range("Q2:Q" & n)
  Date2Array = .Range("R2:R" & n)
  myLimit = UBound(CIArray)
  k = 1
  Do
    StartBlock = k
    LinkDesc = CIArray(k, 1)
    Do Until CIArray(k + 1, 1) <> LinkDesc
      'Debug.Assert k < 6420
      k = k + 1
      If k >= myLimit Then Exit Do
    Loop
    'Debug.Print StartBlock, k
    'here, process the block:
    'Range("L" & StartBlock + 1 & ":L" & k + 1).Select
    If k > StartBlock Then  'if more than one member:
      For i = StartBlock To k
        Date1 = Date1Array(i, 1)
        Date2 = Date2Array(i, 1)
        For j = i + 1 To k
          If Date1Array(j, 1) >= Date1 Then
            If Date2Array(j, 1) <= Date2 Then
              'Stop
              .Cells(j + 1, 1).Resize(, 26).Interior.Color = RGB(220, 0, 0)
            End If
          End If
        Next j
      Next i
    End If
    'end processing of block.
    k = k + 1
  Loop Until k >= myLimit
End With
'Unload UserForm1
UserForm1.Label1.Caption = "All Duplicate CI's are highlighted in RED color."
UserForm1.Label2.Caption = "Report not saved !"
Errhandler:
Application.ScreenUpdating = True
End Sub
 
Last edited:
p45cal said:
Yes, that's what testing is all about. See attached code, several tweaks as well, so again, copy the whole code.
Even with your 6.5k row file I don't think you need to update the user with progress information as it takes less than 1/3 seconds on my old machine to process it.
Test it again please.
Code: 
Sub chkdupCI()
Dim n As Long, CIArray, Date1Array, Date2Array, myLimit As Long, k As Long, StartBlock As Long, LinkDesc As String, i As Long, j As Long
'On Error GoTo Errhandler
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim Date1 As Date, Date2 As Date
Dim CI As String
Set ws = Sheets(1)
ws.Activate
n = Cells(Rows.Count, "B").End(xlUp).Row
 
With ws
  With .Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("L2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Range("Q2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Range("R2"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    .SetRange Range("A1:Z" & n)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With
 
  CIArray = .Range("L2:L" & n)
  Date1Array = .Range("Q2:Q" & n)
  Date2Array = .Range("R2:R" & n)
  myLimit = UBound(CIArray)
  k = 1
  Do
    StartBlock = k
    LinkDesc = CIArray(k, 1)
    Do Until CIArray(k + 1, 1) <> LinkDesc
      'Debug.Assert k < 6420
      k = k + 1
      If k >= myLimit Then Exit Do
    Loop
    'Debug.Print StartBlock, k
    'here, process the block:
    'Range("L" & StartBlock + 1 & ":L" & k + 1).Select
    If k > StartBlock Then  'if more than one member:
      For i = StartBlock To k
        Date1 = Date1Array(i, 1)
        Date2 = Date2Array(i, 1)
        For j = i + 1 To k
          If Date1Array(j, 1) >= Date1 Then
            If Date2Array(j, 1) <= Date2 Then
              'Stop
              .Cells(j + 1, 1).Resize(, 26).Interior.Color = RGB(220, 0, 0)
            End If
          End If
        Next j
      Next i
    End If
    'end processing of block.
    k = k + 1
  Loop Until k >= myLimit
End With
'Unload UserForm1
UserForm1.Label1.Caption = "All Duplicate CI's are highlighted in RED color."
UserForm1.Label2.Caption = "Report not saved !"
Errhandler:
Application.ScreenUpdating = True
End Sub
Click to expand...

Hi p45cal you rocks man !

Code seems perfect, speed and results both are optimized now. And yes you are right with this speed it seems meaning less to update labels for iterations.

I learnt a lot with your codes :)

Thanks
 
re:"if we can add a progress bar to the main form"
Not sure what you mean by that.
Just confirm that you want to have a progress bar appear while the process we developed above is going on…
 
Yes I mean to display the progress bar on main form relative to the progress of search routine.

please find attached our final code along with the sample RAW data as source input.
 

Attachments

  • our final code.zip
    300.2 KB · Views: 0
See attached.
The code, apart from being slowed down by the progress indicator is also being slowed down by this line:
DoEvents 'remove this line to speed things up
Delete it (or put an apostrophe at its beginning) to speed things up, but then even with a 6.5k row file to process the progres bar is hardly visible long enough to warrant it being present.
I've made some changes to the Import sub to speed things up. I've left versions of most of the lines I've changed just commented-out, so you can can revert to them if the changes don't meet with your approval.
 

Attachments

  • ABG RAW Data - Search Duplicate Auto CI\'sv2.0.zip
    248.6 KB · Views: 3
p45cal said:
Were you able to use this?
Click to expand...
yup its working fine :)

Rest I am trying to incorporate the progress bar on the main form itself.

Thnks for your proactive approach and awesome code solutions.

Excel+VBA+Chandoo+members like you make me shine. :)
 
Last edited:
You must log in or register to reply here.
Back
Top