Excel Macro Help

Question

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

Answer 1

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

Answer 2

Const sCurrencyFormatShort As String = "$#,##0.00_);($#,##0.00)" Const sCurrencyFormatLong As String = "$#,##0.0000_);($#,##0.0000)"

Sub RoundCurrencyValues()
  Dim rng As Range, crng As Range
  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 Len(crng) > 0 Then
          If .NumberFormat = sCurrencyFormatShort Then _
            crng.Value = WorksheetFunction.Round(crng * (1 + rng), 2)
        ElseIf .NumberFormat = sCurrencyFormatLong Then
          crng.Value = WorksheetFunction.Round(crng * (1 + rng), 4)
        End If
      End With 'crng
    Next 'crng
  End If 'Not rng Is Nothing
End Sub

Answer 3

https://docs.microsoft.com/en-us/office/vba/Language/Concepts/Getting-Started/using-ifthenelse-statements

Need extra if else which up to your specific prices.

In another words,because all cells store number as float,we need more infomation to decide which price is 2 decimals and another is 4 decimals.

Answer 4

Some of my prices have 2 decimals, some have 4.

is there a way for the macro to handle things such that prices with 2 decimals are rounded to exactly 2 decimals and those with 4 decimals are rounded to exactly 4 decimals?

Answer 5

Const sCurrencyFormat As String = "$#,##0.0000_);($#,##0.0000)"

crng.Value = WorksheetFunction.Round(crng * (1 + rng), 4)

here modify to 4 from 2 if you want 4 decimals.