Excel Macro Help

Anonymous

First of all, let me state upfront that I know almost nothing about Excel macros and VBA...

Years ago somebody wrote a small Excel macro for me that needs to be modified. What the macro does is parse each tab of a workbook (the workbook is a price list) and increases/decreases every cell formatted for currency by a percentage indicated in a cell named "pctChange". The macro seems to work fine in cells that are formatted as currency with two decimals. It does not work if the cell is formatted for more than two decimals. In my workbook some prices are with two decimals and some with four decimals. There's not much I can do about that due to the nature of each individual part number.

I need help in modifying the macro such that when run every cell formatted for currency is increased/decreased no matter how many decimals it has. I hope this is possible...

Anyhow, here's the macro:

Option Explicit

Const sCurrencyFormat As String = "$#,##0.00_);($#,##0.00)"
Sub RoundCurrencyValues()
 Dim rng As Range, crng
 On Error Resume Next 'in case no Range("pctChange")
 Set rng = ActiveSheet.Range("pctChange")
 If Not rng Is Nothing Then
   For Each crng In ActiveSheet.UsedRange.Cells
   With crng
       'If cell number format is Currency AND cell not empty
       If .NumberFormat = sCurrencyFormat And Len(crng) > 0 Then _
         crng.Value = WorksheetFunction.Round(crng * (1 + rng), 2)
     End With 'crng
   Next 'crng
 End If 'Not rng Is Nothing
 Set rng = Nothing
End Sub

Locked Question. This question was migrated from the Microsoft Support Community. You can vote on whether it's helpful, but you can't add comments or replies or follow the question.

0 comments

Answer accepted by question author

Andreas Killer 144.1K Volunteer Moderator

Damn, I've really made a fool of myself now. :-)

I was so focused on rounding the values and completely missed the essentials. Please forgive me, I am very sorry.

Most of the code below is designed to catch possible errors. The actual part that changes prices is not longer than your original code, but should run much more faster.

I wish you a nice weekend.

Andreas.

Sub RoundCurrencyValuesAsAppearOnScreen()
Const Title = "RoundCurrencyValuesAsAppearOnScreen"
Dim Where As Range, Here As Range
Dim FirstAddress As String
Dim Factor As Double
Dim CurrencyCode, SaveCalculation, SavePrecisionAsDisplayed, UpdateCount
Dim CheckLocked As Boolean

'Prepare
CheckLocked = ActiveSheet.ProtectContents
If CheckLocked Then
If MsgBox("Sheet is locked, only unlocked cells are updated! Continue?", _
vbOKCancel + vbQuestion + vbDefaultButton2, Title) = vbCancel Then Exit Sub
End If

With Application
'Note:
' The Range.Find method also finds other currency codes with a $, e.g. € on a German system
' No need to use: CurrencyCode = .International(xlCurrencyCode)
CurrencyCode = "$"
.EnableEvents = False
SaveCalculation = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

With ActiveWorkbook
SavePrecisionAsDisplayed = .PrecisionAsDisplayed
.PrecisionAsDisplayed = True
End With

UpdateCount = 0
On Error GoTo Errorhandler

'Get the update factor
Factor = 1 + Range("pctChange")
If Factor = 1 Then Err.Raise vbObjectError + 1, "RoundCurrencyValues"

'Where to search
Set Where = ActiveSheet.UsedRange
'Find all currency values
Set Here = Where.Find(CurrencyCode, LookIn:=xlValues, LookAt:=xlPart)
If Here Is Nothing Then Err.Raise vbObjectError + 99
FirstAddress = Here.Address
Do
With Here
'Skip formulas
If .HasFormula Then GoTo Skip
'Skip text
If Not IsNumeric(.Value2) Then GoTo Skip
'Locked cell?
If CheckLocked Then If .Locked Then GoTo Skip
'Convert
.Value2 = .Value2 * Factor
UpdateCount = UpdateCount + 1
End With
Skip:
'Find next occurrence
Set Here = Where.FindNext(Here)
Loop Until Here.Address = FirstAddress

Errorhandler:
'Restore settings
With ActiveWorkbook
.PrecisionAsDisplayed = SavePrecisionAsDisplayed
End With
With Application
.EnableEvents = True
.Calculation = SaveCalculation
.ScreenUpdating = True
End With

'Process errors if any
Select Case Err.Number
Case 0
If UpdateCount > 0 Then
Range("pctChange") = 0
MsgBox UpdateCount & " price(s) updated", vbInformation, Title
Else
MsgBox "No cells found to update", vbInformation, Title
End If
Case vbObjectError + 1
MsgBox "No value in 'pctChange', aborted", vbExclamation, Title
Case vbObjectError + 99
'Used instead of 'Exit Sub'
Case Else
If Err.Source = "" Then Err.Source = Application.Name
Debug.Print "Source : " & Err.Source
Debug.Print "Error : " & Err.Number
Debug.Print "Description: " & Err.Description
If MsgBox("Error " & Err.Number & ": " & vbNewLine & vbNewLine & _
Err.Description & vbNewLine & vbNewLine & _
"Enter debug mode?", vbOKCancel + vbDefaultButton2, Err.Source) = vbOK Then
Stop 'Press F8 twice
Resume
End If
End Select
End Sub

0 comments

43 additional answers

Anonymous

2022-01-18T22:41:20+00:00
Hi there

Our colleague Andreas made a good point in his comments.

Checking by the cell formats for their decimal places is extremely complex

For that reason, I choose to evaluate the number values (Prices) by converting them as Text and checking if it contains the currency symbol "$" and the decimal point "." (or "," depending on the Application settings)

I run the following macro on five of the sheets of the sample file provided and worked fine.

Please, try it and let us know.

@ Andreas,

Please,

Feel free to bring in your expertise and make this code more watertight.

I'll appreciate your Input

Thank you in advance

'''''--------------------------------------------------------------------------------------

Sub RoundMyCurrencyValues()

Dim myPct As Range, cPrice As Range

Dim decPlaces As Integer

On Error Resume Next 'in case no Range("pctChange")

Set myPct = ActiveSheet.Range("pctChange")

If Not myPct Is Nothing Then

For Each cPrice In ActiveSheet.UsedRange.Cells

'''------ Cell checking part---------------------------------------------------------------------------------------
```
    With cPrice 

                If Not IsEmpty(cPrice) Then  '' If cell is not empty/blank 

                If .HasFormula = False Then  '' Check if the cell does not contains a formula 

                If IsNumeric(.Value2) Then  '' Check if the cell contains a valid number 

                If InStr(.Text, Application.DecimalSeparator) &gt; 0 Then ''' Check if the number has decimals (as per Excel Appl. settings) 

                If InStr(.Text, "$") &gt; 0 Then ''' Check if the number is formatted as currency 
```
'''--------------------------------------------------------------------------------------------------------------------
```
                '' the length of the decimal places determines the rounding value 

                '' Note: the -1 is to deduct the currency symbol 

                decPlaces = Len(.Text) - InStr(.Text, Application.DecimalSeparator) - 1
```
''''---------------------------------------------------------------------------------------------------------------
```
                ''' Update Prices 

                .Value2 = WorksheetFunction.Round(cPrice \* (1 + myPct), decPlaces) 

                End If 

                End If 

                End If 

                End If 

                End If 

    End With 

Next cPrice 
```
End If 'Not rng Is Nothing

End Sub

''''---------------------------------------------------------------------------------------------------------------------

I hope this helps you and gives a solution to your problem

Do let me know if you need more help

Regards

Jeovany
Was this answer helpful?

0 comments No comments
Anonymous

2022-01-18T23:05:14+00:00
VBA is reporting a compile error. The problem should be in line 19 of the macro with this command:
```
             if biggerThanOne(crng)
```
Was this answer helpful?

0 comments No comments
Anonymous

2022-01-18T23:21:47+00:00

Jeovany, I think that you nailed the problem! THANK YOU!

Your VBA code appears to be running correctly no matter whether the $ price is 2 decimals, 3 decimals, 4 decimals... Of course, I will be doing more testing in the next few days to make sure that there are no surprises.

I have one last request... Would it be possible to embed some code that lets me know when the macro has finished running?
Was this answer helpful?

0 comments No comments
Anonymous

2022-01-18T23:52:06+00:00

Great!!!

Re, Your new request

Add the following line at the end of the code, before the End Sub

MsgBox "Job Done!, Prices Updated"

End Sub

And change the message part in red as per your needs
Was this answer helpful?

0 comments No comments