'小数点以下を上付き文字にするマクロ

'このツールは数値を指定桁で丸めます。元に戻すことはできません。
'データを失う危険性があるので、必ずバックアップのある状態で
'実行してください。

'不要な0の非表示は、文字色をセル色と同じにすることで実現しています。
'そのため、セル色や文字色を変更した場合は、このマクロを再度実行する
'必要があります。

'文字列を数値に戻すには、例えば以下の手順で加算貼り付けを行います。
'  空白セルを選択し、[編集]-[コピー]する。
'  対象範囲を選択し、[編集]-[形式を選択して貼り付け]を選ぶ。
'  [値]と[加算]のオプションボタンを選択して[OK]ボタンをクリックする。

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

Option Explicit

Sub MySuperscript()
    Const myTitle As String = "小数点以下を上付き文字に設定"
    Dim r As Range
    Dim s As String
    Dim v As Variant
    Dim i As Integer, j As Integer
    Dim digit As Integer
    Dim formatString As String
    Dim zeroDisplay As Boolean
    Dim msg1 As String

    msg1 = "このツールは数値を指定桁で丸めます。元に戻すことはできません。" _
        & Chr$(10) & "データを失う危険性があるので、必ずバックアップの" _
        & "ある状態で実行してください。"

    If TypeName(Selection) <> "Range" Then
        MsgBox "セル範囲を選択して、実行してください。", _
            vbExclamation, myTitle
        Exit Sub
    End If

    '警告メッセージの表示
    If MsgBox(msg1, vbExclamation Or vbOKCancel, myTitle) _
        <> vbOK 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:="小数点以下の桁数(1-16）を入力してください。", _
            Title:=myTitle, Type:=1)
        If VarType(v) = vbBoolean Then Exit Sub
        If v >= 1 And v <= 16 Then
            digit = v
            formatString = "0." & String(digit, "0")
            Exit Do
        Else
            MsgBox "1から16の整数を入力してください。", vbExclamation, myTitle
        End If
    Loop

    '下位の0の表示の有無を問い合わせる
    v = MsgBox(msg1 & Chr$(10) & Chr$(10) & "小数点以下" & digit & _
        "桁の文字列を作成します。" & Chr$(10) & "下位の0を表示しますか？", _
        vbExclamation Or vbYesNoCancel Or vbDefaultButton3, myTitle)
    If v = vbCancel Then Exit Sub
    If v = vbYes Then zeroDisplay = True Else zeroDisplay = False

    Application.ScreenUpdating = False

    For Each r In Selection.Cells
        
        '数値であるかチェック
        If r.HasFormula Then
            v = Empty
        Else
            v = r.Value
            Select Case VarType(v)
                Case vbString
                    If IsNumeric(v) Then v = CDbl(v) Else v = Empty
                Case vbDouble
                Case Else
                    v = Empty
            End Select
        End If

        If Not IsEmpty(v) Then

            '指定桁で丸める
            v = SRound(v, digit)

            '文字列に変換
            s = Format$(v, formatString)

            '小数点の位置を取得
            i = InStr(1, s, ".", 0)

            'セルに文字列を代入し小数点以下を上付き文字に設定する
            If i > 0 Then
                r.Value = "'" & s
                r.Characters(i + 1).Font.Superscript = True

                '不要な0の文字色をセルと同じ色にする
                If Not zeroDisplay Then
                    j = Len(s)
                    Do While j >= i
                        If Mid$(s, j, 1) <> "0" Then Exit Do
                        j = j - 1
                    Loop
                    If j < Len(s) Then
                        r.Characters(j + 1).Font.Color = r.Interior.Color
                    End If
                End If
            End If
            r.HorizontalAlignment = xlRight
        End If
    Next
End Sub


'四捨五入を行う関数

Function SRound(ByVal dfNumber As Double, ByVal iNum_Digits As Integer) As Double
    Dim sNumber As String
    Dim dfIntNum As Double
    Dim iNum1 As Integer
    Dim iExponent  As Integer
    Dim iNum_Digits2 As Integer

    '数値を15桁の文字列に変換
    sNumber = Mid$(Format(Abs(dfNumber), ".000000000000000E+000"), 2)

    '仮数部を整数として取得
    dfIntNum = CDbl(Left$(sNumber, 15))

    '指数部を取得
    iExponent = CInt(Mid$(sNumber, 17, 4))

    '文字列上の丸める桁を取得
    iNum_Digits2 = iExponent + iNum_Digits

    '丸める桁が15より大きい場合はそのまま値を返す
    If iNum_Digits2 > 15 Then
        SRound = Sgn(dfNumber) * (dfIntNum * (10 ^ (iExponent - 15)))
        Exit Function
    End If

    '指定桁-1の数字を取得
    If (iNum_Digits2 < 0) Or (iNum_Digits2 = 15) Then
        iNum1 = 0
    Else
        iNum1 = CInt(Mid$(sNumber, iNum_Digits2 + 1, 1))
    End If

    '丸め
    If iNum1 < 5 Then
        SRound = Int(dfIntNum / (10 ^ (15 - iNum_Digits2))) _
            * (10 ^ (iExponent - iNum_Digits2)) * Sgn(dfNumber)
    Else
        SRound = (Int(dfIntNum / (10 ^ (15 - iNum_Digits2))) + 1) _
            * (10 ^ (iExponent - iNum_Digits2)) * Sgn(dfNumber)
    End If

End Function