'小数点位置をそろえるマクロ

Option Explicit

Sub UniformPointPos()
    Const leftFormat As String = ""
    Const rightFormat As String = "_ "

    Const myTitle As String = "小数点位置そろえ"
    Const msg1 As String = _
    "表示する小数桁数の最大値(1から16)、または0（自動)を入力してください。"
    Dim r As Range
    Dim s As String
    Dim v As Variant
    Dim i As Long, j As Long, k As Long, l As Long
    Dim m As Long, n As Long
    Dim a() As Long

    If TypeName(Selection) <> "Range" Then Exit Sub
    Set r = Application.Intersect(ActiveSheet.UsedRange, Selection)
    If r Is Nothing Then Exit Sub
    r.Select

    '小数桁の上限を入力
    Do While True
        v = Application.InputBox(prompt:=msg1, Title:=myTitle, Type:=1)
        If VarType(v) = vbBoolean Then Exit Sub
        l = CInt(v)
        If (l < 0) Or (l > 16) Then
            MsgBox msg1, vbExclamation, myTitle
        Else
            Exit Do
        End If
    Loop

    '対象範囲の小数桁の最大値を取得する
    n = 0
    m = 0
    i = 1
    For Each r In Selection.Cells
        v = r.Value
        If VarType(v) = vbDouble Then

            '文字列に変換
            s = Format$(v, "0.##################")

            '小数桁数を取得
            k = Len(s) - InStr(1, s, ".", 0)

            '現在の最大値と比較
            If k > m Then m = k

            '整数値の場合、後で処理するために場所を記憶
            If k = 0 Then
                n = n + 1
                ReDim Preserve a(1 To n)
                a(n) = i
            End If
        End If
        i = i + 1
    Next

    '対象範囲全体に表示形式を設定する
    If m = 0 Then
        'すべて整数値の場合
        Selection.NumberFormatLocal = leftFormat & "0" & rightFormat
        Exit Sub
    Else
        '小数桁があった場合
        If l > 0 Then m = l
        Selection.NumberFormatLocal _
            = leftFormat & "0." & String(m, "?") & rightFormat
    End If

    '整数値に対して表示形式を設定する
    If n = 0 Then Exit Sub
    s = leftFormat & "0_." & Application.Rept("_0", m) & rightFormat
    i = 1
    j = 1
    For Each r In Selection.Cells
        If i = a(j) Then
            r.NumberFormatLocal = s
            j = j + 1
            If j > n Then Exit For
        End If
        i = i + 1
    Next
End Sub