Search code examples
regexexcelvbadecimal-point

Macro to change the number format to a certain number of decimal places

I am looking to change the number of decimals displayed in a cell using a macro. I want the macro to work with all kinds of custom formats, I have the following examples that I want to properly change:

$ #,##0.00" Test 0.00";[Red]$ -#,##0.00" Test 0.00"
$ #,##0.00" Test 0.00";[Red]$ -#,##0.00" Test 0.00"
$ #,##0.0000" Test 0.00";[Red]$ -#,##0.0000" Test 0.00"
$ #,##0" Test 0.00";[Red]$ -#,##0" Test 0.00"
$ #,##0.0000000" Test 0.00";[Red]$ -#,##0.0000000" Test 0.00"
$ #,##0%" Test 0.00";[Red]8" Test 0.00"
$ #,##0%" Test 0.00";[Red]8" Test 0.00"
"Test 0.0000"$ #,##0.0000000" Test 0.00";[Red]"Test 0.0000"$ -#,##0.0000000" Test 0.00"
"Test 0.0000"$ #,##0%" Test 0.00";[Red]"Test 0.0000"8" Test 0.00"
"Test 0.0000"$ #,##0%" Test 0.00";[Red]"Test 0.0000"8" Test 0.00"

Note, I have used 0.00 inside quotes. I don't want the script to change this, I want them to stay that way.

I have started a bit using RegEx but I am not sure if this is the right approach:

Sub ChangeDecimalPoints(sRange As Range, DP As Integer)
Dim sCell As Range, sFmt As String
Dim regEx As New VBScript_RegExp_55.RegExp, arrMatch As Variant, i As Long

For Each sCell In sRange
    sFmt = sCell.NumberFormat
    With regEx
        .Global = True
        .ignorecase = True
        .Pattern = "[^""]+|(0\.[0]+)"
        If .test(sFmt) Then
            Set arrMatch = .Execute(sFmt)
            i = 0
            Do Until i = arrMatch.Count
                Debug.Print sFmt, arrMatch(i)
                i = i + 1
            Loop
        End If
    End With
Next sCell
End Sub

Edit: To show an example of how I want it to change, if I run the following (assuming the list above shows the .NumberFormat of Selection):
ChangeDecimalPoints Selection, 2

I want the output of the above to be the following:

$ #,##0.00" Test 0.00";[Red]$ -#,##0.00" Test 0.00"
$ #,##0.00" Test 0.00";[Red]$ -#,##0.00" Test 0.00"
$ #,##0.00" Test 0.00";[Red]$ -#,##0.00" Test 0.00"
$ #,##0.00" Test 0.00";[Red]$ -#,##0.00" Test 0.00"
$ #,##0.00" Test 0.00";[Red]$ -#,##0.00" Test 0.00"
$ #,##0.00%" Test 0.00";[Red]8" Test 0.00"
$ #,##0.00%" Test 0.00";[Red]8" Test 0.00"
"Test 0.0000"$ #,##0.00" Test 0.00";[Red]"Test 0.0000"$ -#,##0.00" Test 0.00"
"Test 0.0000"$ #,##0.00%" Test 0.00";[Red]"Test 0.0000"8" Test 0.00"
"Test 0.0000"$ #,##0.00%" Test 0.00";[Red]"Test 0.0000"8" Test 0.00"
Solution

  • After spending all afternoon thinking about this, I found an answer that works for all the example formats I've posted above:

    Sub ChangeDecimalPoints(sRange As Range, DP As Integer)
Dim sCell As Range, sFmt As String, sNewFmt As String
Dim regEx As New VBScript_RegExp_55.RegExp, arrMatch As Variant, i As Long, arrReplace As Variant

sNewFmt = "0" & IIf(DP > 0, ".", "")
For i = 1 To DP
    sNewFmt = sNewFmt & "0"
Next i

For Each sCell In sRange
    sFmt = sCell.NumberFormat
    With regEx
        .Global = True
        .ignorecase = True
        .Pattern = "[\""].*?[\""]|(0\.?0*)"
        If .test(sFmt) Then
            Set arrMatch = .Execute(sFmt)
            For i = arrMatch.Count - 1 To 0 Step -1
                If Not IsEmpty(arrMatch(i).submatches(0)) Then
                    sFmt = WorksheetFunction.Replace(sFmt, arrMatch(i).FirstIndex + 1, arrMatch(i).Length, sNewFmt)
                End If
            Next i
        End If
    End With
    sCell.NumberFormat = sFmt
Next sCell
End Sub

    I am not sure if there is a way to get this to work without .submatches, I assume there might be a way using `regEx.Replace(input, "$match") but I was too lazy for that and this works just as well.