Calculation takes too much time in VBA

[mehidy1437]

Hi There,

Please see below the code, it's taking too much time to calculate the cell's value.
I'm trying to reduce 10% of the selected cell value & show the result in the same cells for the range.
It's working fine, but taking more time to complete the task.

For general formatted cells, it takes a bit less time than the currency formatted cells.
For 2000 cells, it takes more than 10 minutes.

How can I speed this code?
Please help.

Dim rng As Range
Dim myVal As Range, percentage As Double

percentage = Application.InputBox("Eneter the Percentage Value Ex:10 for 10%", "Percentage", 10, , , , , 2)


    Set rng = Selection
    For Each myVal In rng

     If myVal.Value > 0 Then
          

    myVal = myVal.Value - ((myVal.Value * percentage) / 100)
    myVal = Application.Round(myVal, 2)

    End If

    Next myVal

 

[BSALV]

the initial code = 2,000 times reading of one cell at a time slows down the process.
minimize the number of interactions with your sheet !
Read the whole range in 1 time to an array, process the array in memory and write that array to the sheet again = 2 interactions !

Set rng = Selection
    For Each myVal In rng

i'm not sure how to look at my macro in #9, 2nd part.
That's an evaluate within that range.
Is that reading and writing simultaniously, so 1 interaction ?

 

[BSALV]

Another point, i'm not sure about.
OP uses 3 times myVal.value, isn't that 6,000 reads ?
if it was directly assigned to a variable myvalue, would that have made a big difference ?
"the taste of the pudding is in the eating"

 

[Zyndstoff]

the initial code = 2,000 times reading of one cell at a time slows down the process.

Of course, that's true - but 10 minutes? That is ridiculous. It took about 3 seconds on my machine, the exact same code.

 

[DanteAmor]

Try the following whitout loop.

It works for multiple columns. For 8 thousand cells the result is immediate.

Sub test2()
  Dim percent As Double
  percent = 1 - Application.InputBox("Enter the Percentage Value Ex:10 for 10%", "Percentage", 10, , , , , 2) / 100
  With Selection
    .Value = Evaluate("=IF({1},ROUND(" & .Address & "*" & percent & ",2))")
  End With
End Sub

 

[BSALV]

#9 = 1.5 sec for 1,000,000 cells
#14 = immediate for 8,000 cells
means immediate = 0.012 sec

i don't understand the construction if({1}, ... in "=IF({1},ROUND("

 

[DanteAmor]

#9 = 1.5 sec for 1,000,000 cells

For One million cells
#9 = 34.97 secs
#14 = 3.3 secs

.Value = Evaluate("=IF({1},ROUND(" & .Address & "*" & percent & ",2))")

Calculates the result and puts it in the same cell.

 

[BSALV]

#9 = 34.97 secs

do you use an old egyptian clay tablet ???

I didn't know that construction ! Thanks.

 

[DanteAmor]

#4 = 34.97 secs

I meant post#4
Post#9, I don't understand how the data should be, it's supposed to work with the selected data, according to the OP.

 

[mehidy1437]

How about:

Option Explicit
Sub test()
Dim arr(), i&, j&, percent As Double
ReDim arr(1 To Selection.Rows.Count, 1 To Selection.Columns.Count)
percent = 1- Application.InputBox("Enter the Percentage Value Ex:10 for 10%", "Percentage", 10, , , , , 2) / 100
    For i = 1 To Selection.Rows.Count
        For j = 1 To Selection.Columns.Count
            If IsNumeric(Selection.Cells(i, j)) Then
                arr(i, j) = round(Selection.Cells(i, j).Value * percent, 2)
            Else
                arr(i, j) = Selection.Cells(i, j).Value
            End If
        Next
    Next
        Selection.Value = arr
End Sub

How can I add a condition to run this code on visible cells only ?