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

 

[mohadin]

Hi
Try This method

Sub test()
    Dim rng As Range
    Dim a As Variant, percentage As Double
    percentage = Application.InputBox("Eneter the Percentage Value Ex:10 for 10%", "Percentage", 10, , , , , 2)
    a = Selection
    For i = 1 To UBound(a)
        a(i, 1) = Application.Round(a(i, 1) - ((a(i, 1) * percentage) / 100), 2)
    Next
    Selection = a
End Sub

[/CODE]

 

[Zyndstoff]

I just tried your code, it took about 3 seconds for 40.000 cells.
I can't reproduce the issue.

 

[bebo021999]

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

 

[Zyndstoff]

Hi
Try This method

Sub test()
    Dim rng As Range
    Dim a As Variant, percentage As Double
    percentage = Application.InputBox("Eneter the Percentage Value Ex:10 for 10%", "Percentage", 10, , , , , 2)
    a = Selection
    For i = 1 To UBound(a)
        a(i, 1) = Application.Round(a(i, 1) - ((a(i, 1) * percentage) / 100), 2)
    Next
    Selection = a
End Sub

[/CODE]

This works only for column 1, not for a range of multiple rows and columns.

 

[mehidy1437]

@mohadin many thanks for your help, it works at full speed.

@bebo021999 thanks, I have marked your code as a solution, as it's working in multiple columns.

 

[mohadin]

Multi columns

Sub test()
    Dim a As Variant, percentage As Double
    Dim i As Long, ii As Long
    percentage = Application.InputBox("Eneter the Percentage Value Ex:10 for 10%", "Percentage", 10, , , , , 2)
    a = Selection
    For i = 1 To UBound(a)
    For ii = 1 To UBound(a, 2)
        a(i, ii) = Application.Round(a(i, ii) - ((a(i, ii) * percentage) / 100), 2)
    Next: Next
    Selection = a
End Sub

 

[bebo021999]

Multi columns

Sub test()
    Dim a As Variant, percentage As Double
    Dim i As Long, ii As Long
    percentage = Application.InputBox("Eneter the Percentage Value Ex:10 for 10%", "Percentage", 10, , , , , 2)
    a = Selection
    For i = 1 To UBound(a)
    For ii = 1 To UBound(a, 2)
        a(i, ii) = Application.Round(a(i, ii) - ((a(i, ii) * percentage) / 100), 2)
    Next: Next
    Selection = a
End Sub

code fail, if ,by change, there were cells among selection, with text, not value.

 

[BSALV]

1.5 sec for 1,000,000 cells

Sub speedy()
    
    'preparation
     a = WorksheetFunction.RandArray(1000, 1000, 100, 200)      'preparing random 1,000 * 1,000 cells, value between 100 and 200, not integer
     With Range("A1").Resize(UBound(a), UBound(a, 2))
          .Value = a                                            'writing it to your sheet
     .Offset(10, 10).Resize(10, 10).Value = "text"

          MsgBox "ready ??"
     'real stuff
          ThisWorkbook.Names.Add "perc", 0.1                    'the percentage correction
          t = Timer                                             'start timer
          .Name = "test"                                        'defined name for your range
          .Value = [IF(ISNUMBER(test),round(test*perc,2),test)]                         'evaluate and write back to original range
          t1 = Timer
     End With
     MsgBox t1 - t
End Sub

 

[Zyndstoff]

So, the problem is solved. Has anybody some explanation why the original code took so abysmally long for the OP?
IMHO the code was perfectly okay, I have no clue why it is that slow on the OP's machine since it works normally fast on my own.