Round to nearest 10%

[Dr. Demento]

Thanks to shg, I'm now able to estimate how much time a sub has left before it's complete. However, when I put this function within a loop, I'd like to test if the % complete (dPctComp) is a multiple of 10% (so that the function doesn't produce an output with every loop, only at each 10% complete. From what I've read, the nuances of matching a double are mind-boggling (clearly out of my ability). However, I'm hoping someone can tell me what is wrong with this formula or if I need to use a different approach.

I've tried using rounding factor (rFactor) as a double (0.10) or long (10 (%)), but neither one is ever true. I realize that with large loops, the equation may be true over a confined range (10% of 10,000 is 1,000 and the test may be true from 990 - 1010 (or something like that)), which is acceptable. In fact, if you can put in a variable that will allow the degree of precision, that would be awesome!

Dim dPctComp As Double
   dPctComp = 0#
Dim rFactor As Long
  rFactor = 10 ' ~~ Rounding factor (%)

If CDbl(Round(dPctComp * rFactor, 1)) - CInt(Round(dPctComp * rFactor, 1)) <> 0# then DoStuff ' [URL]https://stackoverflow.com/a/1795444\[/URL]

I feel like I'm flailing around in the dark with this one.

Thanks y'all.

 

[Andrew Fergus]

Hi

Why do you want to do this?
Unless it is a really long loop I doubt the processing overhead of continually updating the status bar would exceed the calculations needed to show this at each 10%.

What I often do is only ever show a rounded value (e.g. 15.1% would show as 15%) so that at least you can read what is happening with the status bar if the processing is very fast.

Another method if you are worried about processing overhead and/or readability of the status bar is to do 1 of 2 things:
1) Within the main loop only invoke the status bar update every nth iteration e.g. every 10th or 15th etc.
2) Following on from above you could pre-calculate the end loop number, divide that by 10 to come up with a value n and only show the status bar update at each multiple of n which would give you the 10%, 20, 30% etc.

If you need assistance with implementing this you will need to share the code you are currently using.

Andrew

 

[Tetra201]

See if the following is of any help to you:

Sub Test()
    Dim dPctComp As Double, Precision As Double, Trigger As Double
    Precision = 0.1
    Trigger = -1
    For dPctComp = 0 To 1 Step 0.0000001
        If WorksheetFunction.Floor(dPctComp, Precision) > Trigger Then
            Trigger = WorksheetFunction.Floor(dPctComp, Precision)
            Application.StatusBar = Format(Trigger, """Percent complete:"" 0%")
            DoEvents
        End If
    Next dPctComp
    Application.StatusBar = False
End Sub

 

[Dr. Demento]

Andrew,

Thanks for the feedback (love the fish signature, btw. May have to steal it

I was hoping for a function that I could reference (without knowing the number of iterations) in various subs. Hence, the attempt at percentages instead of solid counts.

Unfortunately, for the number of loops/iterations, I did experience a significant hit on efficiency with the running with every loop.

 

[Dr. Demento]

Tetra,

Thank you. I will have to play around with that to see if that will work.

I'm unclear why the Step 0.0000001 on the dPctComp loop; I'm sure I'll have other questions.

Thanks again.

 

[Andrew Fergus]

I'm curious to see the code you are using. I'm sure a solution can be applied to your situation but it's hard to say without seeing what is currently going on.

 

[Tetra201]

... I'm unclear why the Step 0.0000001 on the dPctComp loop...

This is to slow down this demo sub. Just run it and watch the Excel status bar (lower left corner of the window).

 

[Dr. Demento]

I'm curious to see the code you are using.

I'll give it a go tomorrow; I'm always loathe to use my code because it's usually chock full of custom functions/queries and I either have to go back and genericize it or include all the peripherals. Painful, but I understand your point.

 

[Andrew Fergus]

How about just the loop structure(s) and strip out the rest? Add some notes on where the loop limit(s) come from and what sort of value(s) it will be. That should be enough to work with.

Edit: and also include where you are currently using the % complete calculation.

 

[Dr. Demento]

Andrew,

I think I got it working, thanks to Tetra's suggestion using FLOOR. As requested, here's my code. Please let me know if there's some function I forgot to include. I'd appreciate any help you can offer.

The output is the Immediate Window instead of the status bar. I noticed that the first realistic estimate of time remaining is around 50-60% remaining.

Option Explicit
Option Base 1
Public arr_downCount() As Variant

Sub test_downCountRemaining()

Dim precision As Double
  precision = 0.05
  
Dim cntr As Long, _
    total As Long
  total = 1000000
  
  For cntr = 1 To total
    downCountRemaining cntr, total, precision, True
  Next cntr
End Sub

Public Function downCountRemaining(cntr As Long, _
                                   total As Long, _
                                   Optional precision As Double = 0.01, _
                                   Optional nlbPrint As Boolean = False) As Variant
' ~~ Returns estimated time to complete based on start time and percent complete
' [URL]https://www.mrexcel.com/forum/excel-questions/1042899-help-converting-code-time-remaining-function.html#post5006232[/URL]
 
Dim dPctCompl As Double
  dPctCompl = cntr / total
  
Dim arr_prec As Long
  arr_prec = WorksheetFunction.RoundUp(1 / precision, 0) + 2 ' ~~ (+1) for header, (+1) for final entry

Static dcr_cntr As Long
Static trigger As Double
Static bnl_arrAlloc As Boolean

  If cntr = 1 Then _
    trigger = -1
  
    
  If IsArrayAllocated(arr_downCount) = False Then
    
    ReDim arr_downCount(1 To 5, 1 To arr_prec) ' ~~ Will capture remaining time in x% increments (dependent on precision)
    bnl_arrAlloc = True
    
'    arr_hdrFill_xPose arr_downCount, "Counter", "mTimer", "Time Elapsed (s)", "% Remaining", "Time Remaining (s)"
  
    dcr_cntr = 1  ' ~~ Initial entry
    trigger = WorksheetFunction.Floor(dPctCompl, precision)
    
    arr_downCount(1, dcr_cntr + 1) = dcr_cntr
    arr_downCount(2, dcr_cntr + 1) = MicroTimer
    arr_downCount(3, dcr_cntr + 1) = Format((arr_downCount(2, dcr_cntr + 1) - arr_downCount(2, 2)), "0.0000")
    arr_downCount(4, dcr_cntr + 1) = Format(1 - dPctCompl, "0%") & " remaining"
    arr_downCount(5, dcr_cntr + 1) = "Processing . . ."
    
    Debug.Print Format(1 - dPctCompl, " 0% remaining") & " | " & _
                "Processing . . ."
  
  Else
    If WorksheetFunction.Floor(dPctCompl, precision) > trigger Then
    
      If dPctCompl < 1 Then
        dcr_cntr = dcr_cntr + 1
        arr_downCount(1, dcr_cntr + 1) = dcr_cntr
        arr_downCount(2, dcr_cntr + 1) = MicroTimer
        arr_downCount(3, dcr_cntr + 1) = Format((arr_downCount(2, dcr_cntr + 1) - arr_downCount(2, 2)), "0.0000")
        arr_downCount(4, dcr_cntr + 1) = Format(1 - dPctCompl, "0%") & " remaining"
        arr_downCount(5, dcr_cntr + 1) = (arr_downCount(2, dcr_cntr + 1) - arr_downCount(2, 2)) * (1 - dPctCompl) / dPctCompl
      
        Debug.Print Format(1 - dPctCompl, """Percent remaining: "" 0%") & " | " & _
                          (arr_downCount(2, dcr_cntr + 1) - arr_downCount(2, 2)) * (1 - dPctCompl) / dPctCompl
      
        trigger = WorksheetFunction.Floor(dPctCompl, precision)
        
      ElseIf dPctCompl = 1 Then  ' ~~ Final entry
        dcr_cntr = dcr_cntr + 1
        arr_downCount(1, dcr_cntr + 1) = dcr_cntr
        arr_downCount(2, dcr_cntr + 1) = MicroTimer
        arr_downCount(3, dcr_cntr + 1) = Format(arr_downCount(2, dcr_cntr + 1) - arr_downCount(2, 2), "0.0000")
        arr_downCount(4, dcr_cntr + 1) = "TOTAL TIME (sec)"
        arr_downCount(5, dcr_cntr + 1) = arr_downCount(2, dcr_cntr + 1) - arr_downCount(2, 2)
        
        Debug.Print Format(1 - dPctCompl, """Percent remaining: "" 0%") & " | " & _
                    "TOTAL: " & arr_downCount(2, dcr_cntr + 1) - arr_downCount(2, 2) & vbNewLine
        
        If nlbPrint = True Then
'          arr_print arr_downCount, , True, True
'          AutoFit ActiveSheet
        End If
        
        Erase arr_downCount
        
      End If 'dPctCompl
      
    Else ' WorksheetFunction.Floor(dPctCompl, precision) > trigger Then
      Exit Function
    End If '.Floor
  End If 'IsArrayAllocated
  
End Function

Public Function MicroTimer() As Double
  
  ' Returns seconds.
Dim cyTicks1 As Currency
  Static cyFrequency As Currency
  ' Initialize MicroTimer
  MicroTimer = 0
  
  ' Get frequency.
  If cyFrequency = 0 Then _
    getFrequency cyFrequency
    
  ' Get ticks.
  GetTickCount cyTicks1
  
  ' Seconds = Ticks (or counts) divided by Frequency
  If cyFrequency Then _
    MicroTimer = cyTicks1 / cyFrequency
  
End Function