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

Andreas Killer 144.1K Reputation points Volunteer Moderator

2022-01-24T04:50:59+00:00

One request: Your macro "RoundCurrencyValuesAsAppearOnScreen", when run, zeros out the field "pctChange". Would it be possible to modify the code such that whatever % I have inserted in box "pctChange" is not zeroed out?

Sure,

simply delete the line

Range("pctChange") = 0

Andreas.
Was this answer helpful?

0 comments No comments
Anonymous

2022-01-23T21:39:25+00:00

I like your macro very much, Andreas.

One request: Your macro "RoundCurrencyValuesAsAppearOnScreen", when run, zeros out the field "pctChange". Would it be possible to modify the code such that whatever % I have inserted in box "pctChange" is not zeroed out?

For instance: In tab "Sorted" I insert "6.50%" in box M2 and run your macro. When the macro finishes running, box M2 shows "0.00%". I would like to show "6.50%". That way I know what % increase/decrease I have applied to each tab.

Thanks.
Was this answer helpful?

0 comments No comments
Anonymous

2022-01-22T11:12:27+00:00

Hi Jeovany,

I've done more testing and I think you'll find it interesting that we only need this to round all values.
So your code is a valuable alternative for those who don't want it.

Not relevant to the OP, he permanently set the option.

Andreas.

Sub RoundValuesAsAppearOnScreen()
'Set the precision of the numbers as they're displayed
'This rounds all values, they do not revert if we switch that feature off!
With ActiveWorkbook
.PrecisionAsDisplayed = True
.PrecisionAsDisplayed = False
End With
End Sub

Fine

Have a good weekend
Was this answer helpful?

0 comments No comments
Andreas Killer 144.1K Reputation points Volunteer Moderator

2022-01-22T07:04:08+00:00

Hi Jeovany,

I've done more testing and I think you'll find it interesting that we only need this to round all values.
So your code is a valuable alternative for those who don't want it.

Not relevant to the OP, he permanently set the option.

Andreas.

Sub RoundValuesAsAppearOnScreen()
'Set the precision of the numbers as they're displayed
'This rounds all values, they do not revert if we switch that feature off!
With ActiveWorkbook
.PrecisionAsDisplayed = True
.PrecisionAsDisplayed = False
End With
End Sub
Was this answer helpful?

0 comments No comments