The one-click number auto format

How many times do you right click, format cell, number format, no decimals....?
Select a range, launch the macro: all numbers are formatted according to rules explained below.
Best part: if you select a cell that is part of a pivot datafield, it will format the whole value field (equivalent of value field settings- number format).
Time and sanity saver on a daily basis. Tested on Excel 2003 and Excel 2010.

It is tweaked for my usage but feel free to adapt it, playing on conditions and format output (end of the macro). Final format will be as good as your rules.

Rules Examples:

• All values between 1900 and 2020: no decimals, no 1000's separator
• All values between -5 and +5:  percentage format
• No decimals if the sum of the values has no decimals (not perfect but faster than a loop)
• Value between first January 1995 and first January 2020: Date format
• All values inferior to 10: two decimals if any
• All values inferior to 1000 : one decimal if any

For best usage, save it within a personal macro book ( see http://www.rondebruin.nl/personal.htm) and add a shortcut in the Quick Access Toolbar or a keybord shortcut: The macro will be permanently available.

Enjoy and suggest alternative rules in comments.



Sub oneclicknumberformat()
Application.EnableEvents = False
Dim myarray As Variant
Dim rCcells As Range, rFcells As Range, rAcells As Range, rngsel As Range, trng As Range
Dim pt As PivotTable, ptdn As String, nf As String, rCell As Range, df As PivotField
Dim i As Integer

Set rngsel = Selection
Set trng = rngsel
ptdn = "none"

If rngsel.Cells.Count = 1 Then
If rngsel = vbNullString Then Exit Sub
End If

If ActiveSheet.PivotTables.Count > 0 And Selection.Cells.Count = 1 Then
For i = 1 To ActiveSheet.PivotTables.Count
    If Not Intersect(Selection, ActiveSheet.PivotTables(i).DataBodyRange) Is Nothing Then
      Set pt = ActiveSheet.PivotTables(i)
    For Each df In ActiveSheet.PivotTables(i).DataFields
        ActiveSheet.PivotTables(i).PivotSelect "'" & df.Name & "'", xlDataOnly
        Set trng = Selection
            If Not Intersect(rngsel, trng) Is Nothing Then
            ptdn = df.Name
            trng.ClearFormats
            Exit For
            End If
    Next
    Exit For
    End If
Next
End If

If ptdn = "none" And Selection.Cells.Count > 1 Then
        On Error Resume Next
        Set rCcells = rngsel.SpecialCells(xlCellTypeConstants, xlNumbers)
        Set rFcells = rngsel.SpecialCells(xlCellTypeFormulas, xlNumbers)
            If rCcells Is Nothing And rFcells Is Nothing Then
                Exit Sub
            ElseIf rCcells Is Nothing Then
               Set trng = rFcells
            ElseIf rFcells Is Nothing Then
               Set trng = rCcells
            Else
               Set trng = Application.Union(rFcells, rCcells)
            End If
        On Error GoTo 0
End If

trngmax = Application.Max(trng)
trngmin = Application.Min(trng)
trngmax2 = Application.Max(trngmax, Abs(trngmin))
trngs = Application.Sum(trng)
trngd = trngs - Int(trngs)

If ptdn = "none" And trngmin >= 34700 And trngmax <= 43831 Then
nf = "dd-mmm-yy"
ElseIf ptdn = "none" And trngmin >= 1900 And trngmax <= 2020 Then
nf = "0"

ElseIf trngmax2 < 5 Then
nf = "0%"

ElseIf trngd = 0 Then
nf = "#,##0"
ElseIf trngmax2 < 10 Then
nf = "#,##0.00"
ElseIf trngmax2 < 1000 Then
nf = "#,##0.0"
Else
nf = "#,##0"
End If


If ptdn = "none" Then
trng.Select
trng.NumberFormat = nf
Else
df.NumberFormat = nf
End If
rngsel.Select
Application.EnableEvents = True

End Sub