トップ　>　汎用コード　>　セル内の任意の文字列を上付き文字または下付き文字に設定

'---------------------------------------------------------------------------------------
' 実行マクロ　選択セル範囲の各セルの「※」を上付き文字にする
'---------------------------------------------------------------------------------------
Sub ExampleOfUse_SetSuperscriptForCharacters()

    '検索文字列
    Const C_WHAT As String = "※" '検索文字列はここで設定

    'テスト文字列　使用の場合は次の3行の先頭にある「'」を削除する
'    Range("A1:D1").Value = Array("東京都千代田区※", "東京都台東区※", "注釈※", "※※")
'    Range("A1:D1").EntireColumn.AutoFit
'    Range("A1:D1").Select
    
    '選択しているオブジェクトがセルでなければ抜ける
    If TypeName(Selection) <> "Range" Then
        MsgBox "対象のセル範囲を選択してください", vbInformation, "終了します"
        Exit Sub
    End If
    
    'Rangeオブジェクトに選択セル範囲を設定
    Dim rngTarget As Range
    Set rngTarget = Selection

    'プロシージャを実行する
    Dim strMessage As String
    strMessage = SetSuperscriptForCharacters(rngTarget, C_WHAT, True, 1, 1)

    If strMessage = "" Then
        MsgBox "実行完了しました。", vbInformation
    Else
        MsgBox strMessage, vbExclamation
    End If
End Sub

'---------------------------------------------------------------------------
' セル内の任意の文字列を上付き文字または下付き文字に設定する
'---------------------------------------------------------------------------
'［引数］
'   Target     ：検索対象セル範囲
'   What       ：検索文字列
'   Superscript：上付き文字の設定　True：上付き文字　False：下付き文字
'   Start      ：各セル内で検索を開始する文字の位置（既定：1）
'   Times      ：各セル内で上付きまたは下付きを設定する回数(既定:0:制限なし)
'［戻り値］
'   成功：空の文字列　失敗：メッセージ
'［作成日］
'   2023/06/09
'https://excel.syogyoumujou.com/vba/set_charactersfontsuperscript.html
'---------------------------------------------------------------------------
Function SetSuperscriptForCharacters(ByRef Target As Range, _
                                     ByVal What As String, _
                                     Optional Superscript As Boolean = True, _
                                     Optional Start As Long = 1, _
                                     Optional Times As Long = 0) As String
    'Target にセルが設定されていなければ抜ける
    If Target Is Nothing Then
        SetSuperscriptForCharacters = "セルオブジェクトが設定されていません"
        Exit Function
    End If

    '検索文字列が空の場合は抜ける
    If What = "" Then
        SetSuperscriptForCharacters = "検索文字列がありません"
        Exit Function
    End If

    Dim strAddress As String 'セルアドレス格納用
    Dim lngStart   As Long   '検索スタート位置設定用
    Dim lngPos     As Long   'テキスト内の検索文字列位置格納用
    Dim lngTimes   As Long   'テキスト内での色設定回数 (セル毎)
    Dim lngLen     As Long   '検索文字列の長さ格納用
    Dim rngFnd     As Range  '検索用

    '検索文字列の文字数取得
    lngLen = Len(What)

    '対象セル範囲から検索文字列を含むセルを検索
    Set rngFnd = Target.Find(What:=What, _
                             LookIn:=xlValues, _
                             SearchOrder:=xlByRows, _
                             LookAt:=xlPart, _
                             MatchCase:=False, _
                             MatchByte:=False)
    '検索に一致するセルがなければ抜ける
    If rngFnd Is Nothing Then
        SetSuperscriptForCharacters = "対象の文字列はありません"
        Exit Function
    End If

    '最初に一致したセルのアドレスを取得
    strAddress = rngFnd.Address

    On Error GoTo ERROR_HANDLER

    Do
        'テキスト内の検索文字列に色を設定
        lngStart = Start
        lngTimes = 0
        Do
            'テキストを検索
            lngPos = InStr(lngStart, rngFnd.Value, What, vbTextCompare)

            'テキスト内に検索文字列が見つからなかったら抜ける
            If lngPos = 0 Then Exit Do

            If Superscript Then
                rngFnd.Characters(lngPos, lngLen).Font.Superscript = True
            Else
                rngFnd.Characters(lngPos, lngLen).Font.Subscript = True
            End If
            lngTimes = lngTimes + 1

            '指定した設定回数に到達したら抜ける
            If lngTimes = Times Then Exit Do

            '検索スタート位置を再設定
            lngStart = lngPos + lngLen
        Loop

        '対象セル範囲内で次の検索一致セルを検索
        Set rngFnd = Target.FindNext(rngFnd)

        'セルのアドレスが変数のアドレスと一致したらループを抜ける
    Loop Until strAddress = rngFnd.Address

    On Error GoTo 0
    
    Exit Function
ERROR_HANDLER:
    SetSuperscriptForCharacters = "エラーが発生しました" & vbLf & _
                            "エラー番号:" & Err.Number & vbLf & _
                            Err.Description
    Err.Clear
End Function