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-18T04:55:27+00:00

Unfortunately, your code does not seem to work on $ prices that have 4 decimals. It seems to work just fine with the ones that have 2 decimals.

That's up due to your formattings, there is no way in Excel to determine "a number with 4 decimals". Your old code works because the formatting of the cells are exact the same as shown in the code, if you change it to e.g. "0.00$" or "$ 0.00" your old code did not work either.

A real analysis that really checks all formats for their decimal places is extremely complex. And you need tons of code.

Andreas.
Was this answer helpful?

0 comments No comments

Anonymous

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 

			if biggerThanOne(crng)

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

			else

.NumberFormat = sCurrencyFormatLong

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

			end if

        ElseIf .NumberFormat = sCurrencyFormatLong Then

			if biggerThanOne(crng) then

.NumberFormat = sCurrencyFormatShort 

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

			else

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

			end if

        End If

      End With 'crng

    Next 'crng

  End If 'Not rng Is Nothing

End Sub

function biggerThanOne(crng)

if crng.value>1 then 

	biggerThanOne=true

else

	biggerThanOne=false

end if

end function

0 comments

Anonymous

2022-01-18T00:24:48+00:00

http://e.anyoupin.cn/ceshi/viewdocx/pic/pth/2222.xlsm.xlsm

yes i have received the file.

BTW,You can share the file with the download link at that page after you upload the xlsx file.

the situation of the tables is some how complex.

* Tab "Cyl (BSP)" row 319: $ prices

I really do not know how to figure out this row.

if these rows are fixed area,you can name the longDecimal like name of pctChange,the condition would like

if intersect (longDecimal,crang) is nothing then

run_4_decimal_set()

else

run_2_decimal_set()

end if

while loop all ranges.
Was this answer helpful?

0 comments No comments
Anonymous

2022-01-17T23:42:38+00:00

I just sent you Excel file 2222.xlsm

Please let me know whether or not you received it.

You will see that 99% of the $ prices in the various tabs of the workbook have 2 decimals. But there are some exceptions:

* Tab "Cyl (BSP)" row 319: $ prices have 4 decimals;

* Tab "Cyl 5E" row 6: $ prices have 3 decimals;

* Tab "Cyl 6E" cells I4-I9: $ prices have 3 decimals.

* There probably are more examples that I am not aware of...

The goal is to apply whatever % increase/decrease is specified in the box "pctChange" of each tab with exact rounding of each $ price based on the decimals.
Was this answer helpful?

0 comments No comments