Better way to write this macro.

Risk

Board Regular
Joined
Jul 27, 2006
Messages
71
I’ve got this macro which does what I need it to do but when used for a file with over 10,000 or so “ =HP “ (macro search criteria), it freezes up computers and takes a very long time to process. I took off screen updating to watch it run and at first it was going quickly cell by cell, then its performance worsened and it went very slowly cell by cell so that to complete 12 cells it would take about 20 seconds.

Does anyone know a way to write this formula in a more efficient manor?


Code:
Sub ValueHPAll()
TxtMsg = "You have selected to value all Hyperion formula's in this workbook. If you wish to proceed please select OK"
y = MsgBox(TxtMsg, vbOKCancel, "Proceeding with valuing Hyperion formula's.")

Application.ScreenUpdating = False 'turn off screen updating

If y = 1 Then
    
    Dim sh As Worksheet, HidShts As New Collection
    For Each sh In ActiveWorkbook.Worksheets
        If Not sh.Visible Then
            HidShts.Add sh
            sh.Visible = xlSheetVisible
        End If
    Next sh
                
        For Each x In Worksheets
            Sheets(x.Name).Activate
            Range("a1").Select
            ActiveCell.SpecialCells(xlLastCell).Select
            LastCell = ActiveCell.Address
            Range("a1:" & LastCell).Select
            
            For Each z In Selection
                If InStr(1, z.FormulaR1C1, "HPLNK") = 0 Then
                    If InStr(1, z.FormulaR1C1, "HP") > 0 Or InStr(1, z.FormulaR1C1, "hp") > 0 Then
                        If z.HasFormula Then
                           z.Copy
                           z.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                           :=False, Transpose:=False
                        End If
                    End If
                End If
            Next z
            Range("a1").Select
        Next x
    Application.ScreenUpdating = True 'refresh the screen
    
For Each sh In HidShts
        sh.Visible = xlSheetHidden
    Next sh

Else
MsgBox "You have chosen to cancel this process"

End If

End Sub

I have some other valuing macro's which run at speeds which could probably only be measured in nano seconds, but it doesn't look cell by cell

Code:
Sub ValueAll()
TxtMsg = "You have selected to value all formula's in this workbook. If you wish to proceed please select OK"
y = MsgBox(TxtMsg, vbOKCancel, "Proceeding with valuing all formula's.")

Application.ScreenUpdating = False 'turn off screen updating

If y = 1 Then
     
    Dim sh As Worksheet, HidShts As New Collection
    For Each sh In ActiveWorkbook.Worksheets
        If Not sh.Visible Then
            HidShts.Add sh
            sh.Visible = xlSheetVisible
        End If
    Next sh
     
    Worksheets.Select
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues
    ActiveSheet.Select
    Application.CutCopyMode = False
     
    For Each sh In HidShts
        sh.Visible = xlSheetHidden
    Next sh
     
    Application.ScreenUpdating = True 'refresh the screen
    
Else
MsgBox "You have chosen to cancel this process"

End If

End Sub

Is their a way to rewrite the first marco to make it run as fast as the second?
 

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off

jimrward

Well-known Member
Joined
Feb 24, 2003
Messages
1,792
Office Version
  1. 2016
  2. 2013
  3. 2011
  4. 2010
  5. 2007
Platform
  1. Windows
since your operations do not seem to be calculation based you could turn off calculations before your loop

Application.Calculation = xlManual

and after the loop turn it back on

Application.Calculation = xlAutomatic
 

dcardno

Well-known Member
Joined
Nov 20, 2002
Messages
544
Office Version
  1. 2013
Platform
  1. Windows
Try
Code:
Sub ValueHP2()

Dim sh         As Worksheet
Dim HidShts    As New Collection
Dim y          As Integer
Dim cllForm    As Range
Dim TxtMsg     As String
' all declarations are explicit and typed

TxtMsg = "You have selected to value all Hyperion formula's in this workbook." & Chr(10)
TxtMsg = TxtMsg & "If you wish to proceed please select OK" & Chr(10)
TxtMsg = TxtMsg & "This will replace all Hyperion formulas with their current values"
y = MsgBox(TxtMsg, vbOKCancel, "Proceeding with valuing Hyperion formula's.")

Application.ScreenUpdating = False          'turn off screen updating

If y = 1 Then

    For Each sh In Worksheets
        If Not sh.Visible Then
            HidShts.Add sh
            sh.Visible = xlSheetVisible
        End If
    Next sh

    For Each sh In Worksheets
        ' no need to activate / select worksheets in sequence
        ' no need to define / select used range in worksheets
        For Each cllForm In sh.UsedRange
            If cllForm.HasFormula Then
             ' test for formula / label first
                If InStr(1, cllForm.Formula, "HPLNK") = 0 Then
                    If InStr(1, UCase(cllForm.Formula), "HP") > 0 Then
                     ' trade UCase for OR         
                cllForm.Value = cllForm
                     ' I think that this will be faster than Copy / Paste Special
                    End If
                End If
            End If
        Next cllForm
    Next sh

    For Each sh In HidShts
        sh.Visible = xlSheetHidden
    Next sh
    Application.ScreenUpdating = True       'refresh the screen
Else
    MsgBox "You have chosen to cancel this process"

End If

End Sub

I would be curious to know if this is any faster.
 

HalfAce

MrExcel MVP
Joined
Apr 6, 2003
Messages
9,454
Hello Risk,
I started going through your code and got hung up with work before finishing and it looks
like dcardno came up with pretty much the same idea, but here it is anyway.
Code:
Option Compare Text

Sub ValueHPAll()
TxtMsg = "You have selected to value all Hyperion formula's in this workbook. If you wish to proceed please select OK"
y = MsgBox(TxtMsg, vbOKCancel, "Proceeding with valuing Hyperion formula's.")

If y = 1 Then
  Application.ScreenUpdating = False
  Dim sh As Worksheet, HidShts As New Collection, z As Range
  For Each sh In ActiveWorkbook.Worksheets
    If Not sh.Visible Then
      HidShts.Add sh
      sh.Visible = xlSheetVisible
    End If
    With sh
      For Each z In .UsedRange
        If InStr(1, z.FormulaR1C1, "HPLNK") = 0 Then
          If InStr(1, z.FormulaR1C1, "HP") > 0 Then
            If z.HasFormula Then z.Value = z.Value
          End If
        End If
      Next z
    End With
  Next sh
  For Each sh In HidShts
    sh.Visible = xlSheetHidden
  Next sh
Else
  MsgBox "You have chosen to cancel this process"
End If
Application.ScreenUpdating = True
End Sub

If you're really interested in seeing how much (if any) quicker either of these are than
your original code you can always use the Timer to see exactly how long each one
takes to execute.

(I too would be curious...) :biggrin:
 

dcardno

Well-known Member
Joined
Nov 20, 2002
Messages
544
Office Version
  1. 2013
Platform
  1. Windows
Risk - I hadn't thought about setting "Option Compare Text" as done by HalfAce, but it is agood suggestion; that would simplify the test for the string HP in the cell formula. Compare his test (If InStr(1, z.FormulaR1C1, "HP") > 0) to mine (If InStr(1, UCase(cllForm.Formula), "HP") > 0): by setting the comparison to "Text" you can avoid the explicit conversion of the formula to all upper case. You are instead relying on the implicit conversion due to the comparison setting, which I suspect will be faster.
 

Forum statistics

Threads
1,141,095
Messages
5,704,311
Members
421,338
Latest member
Pepess

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top