'有効桁を表示し、小数点位置をそろえるマクロ

'セル範囲を選択してNumberFormatPointPosマクロを実行してください。

Sub NumberFormatPointPos()
    Const myTitle As String = "小数点位置そろえ"
    Const msg1 As String = "表示する有効桁数(1から15)を入力してください。"
    Const msg2 As String = "表示する小数桁数(0から15)を入力してください。"
    Dim iDigit1 As Integer, iDigit2 As Integer
    Dim v As Variant, vNumber As Variant
    Dim r As Range

    '対象範囲の確定
    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
        iDigit1 = CInt(v)
        If (iDigit1 >= 1) And (iDigit1 <= 15) Then Exit Do
        MsgBox msg1, vbExclamation, myTitle
    Loop

    '小数桁数を入力
    Do While True
        v = Application.InputBox(prompt:=msg2, Title:=myTitle, Type:=1)
        If VarType(v) = vbBoolean Then Exit Sub
        iDigit2 = CInt(v)
        If (iDigit2 >= 0) And (iDigit2 <= 15) Then Exit Do
        MsgBox msg2, vbExclamation, myTitle
    Loop

    Application.ScreenUpdating = False

    For Each r In Selection.Cells
        vNumber = r.Value
        If VarType(vNumber) = vbDouble Then
            v = FmtPt5(CDbl(vNumber), iDigit1, iDigit2)
            If VarType(v) = vbString Then
                r.NumberFormatLocal = v
            Else
                r.Select
                Application.ScreenUpdating = True
                If MsgBox("エラーが発生しました。続行しますか？", _
                    vbYesNo Or vbExclamation, myTitle) <> vbYes Then Exit Sub
                Application.ScreenUpdating = False
            End If
        Else
            r.Select
            Application.ScreenUpdating = True
            If MsgBox("数値データではありません。続行しますか？", _
                    vbYesNo Or vbExclamation, myTitle) <> vbYes Then Exit Sub
            Application.ScreenUpdating = False
        End If
    Next
End Sub

Function FmtPt5(number As Double, digit1 As Integer, _
        digit2 As Integer) As Variant
    Dim s As String
    Dim i As Integer

    '引数のチェック
    If digit1 <= 0 Or digit2 < 0 Then
        FmtPt5 = CVErr(xlErrValue)
        Exit Function
    End If

    '数値を15桁の文字列に変換
    s = Mid$(Application.Text(Abs(number), ".000000000000000E+000"), 2)

    '有効桁の最終桁位置を取得（ROUND関数で使用）
    i = -1 * (CInt(Mid$(s, 17, 4)) - digit1)

    '指定小数桁数で有効桁を表示できない場合はエラーを返す
    If i > digit2 Then
        FmtPt5 = CVErr(xlErrValue)
        Exit Function
    End If

    '書式文字列の作成
    If i > 0 Then
        FmtPt5 = "0." & Application.Rept("0", i) & _
            Application.Rept("_0", digit2 - i)
    Else
        FmtPt5 = "0_." & Application.Rept("_0", digit2)
    End If
End Function