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

'------------------------------------------------------------------------------
' 実行用マクロ
'------------------------------------------------------------------------------
Sub 選択セル範囲から任意の文字列を検索し上付きまたは下付き文字にする()
    
    ' 検索文字列
    Const L_WHAT As String = "※" ' 検索文字列はここで設定

    ' テスト文字列　使用の場合は次の3行の先頭にある「'」を削除する
'    Range("A1:D1").Value = Array("東京都千代田区※", "東京都台東区※", "注釈※", "※※")
'    Range("A1:D1").EntireColumn.AutoFit
'    Range("A1:D1").Select
    
    ' 選択しているオブジェクトがセルでなければ抜ける
    If TypeName(Application.Selection) <> "Range" Then
        MsgBox "対象のセル範囲を選択してください", vbInformation, "終了します"
        Exit Sub
    End If
    
    ' Rangeオブジェクトに選択セル範囲を設定
    Dim rngTarget As Range
    Set rngTarget = Application.Selection
    
    Dim strMessage As String
    '《セル内の任意の文字列を上付き文字または下付き文字に設定》
    ' ** 引数1：検索対象セル範囲
    ' ** 引数2：検索文字列
    ' ** 引数3：上付き文字の設定　True：上付き文字　False：下付き文字（省略可　既定：True）
    ' ** 引数4：各セル内で検索を開始する文字の位置（省略可　既定：1）
    ' ** 引数5：各セル内で上付きまたは下付きを設定する回数(省略可　既定:0:制限なし)）
    '   戻り値：成功：空の文字列　失敗：エラーメッセージ
    strMessage = setSuperscriptForCharacters(rngTarget, L_WHAT)

    ' 結果メッセージ
    If strMessage = "" Then
        MsgBox "実行完了しました。", vbInformation
    Else
        MsgBox strMessage, vbExclamation
    End If
End Sub

'***************************************************************
'* セル内の任意の文字列を上付き文字または下付き文字に設定する
'*--------------------------------------------------------------
'* 概要     | 指定したセル範囲内の任意の文字列を
'*          | 上付き文字または下付き文字に設定する
'*          | 参考：https://excel.syogyoumujou.com/vba/set_charactersfontsuperscript.html
'* 引数     | 1) pRng        ：検索対象セル範囲（ByRef）
'*          | 2) pWhat       ：検索文字列
'*          | 3) pSuperscript：上付き・下付きの設定（既定：True）
'*          |                  True ：上付き文字
'*          |                  False：下付き文字
'*          | 4) pStart      ：各セル内で検索を開始する文字位置（既定：1）
'*          | 5) pTimes      ：各セル内で設定する回数（既定：0：制限なし）
'* 戻り値   | String型
'*          | 成功  ：""（空文字）
'*          | エラー：エラーメッセージ
'* 作成日   | 2023.06.09
'*--------------------------------------------------------------
'* 改修履歴 | 2026.04.06
'***************************************************************
Public Function setSuperscriptForCharacters(ByRef pRng As Range, _
                                            ByVal pWhat As String, _
                                            Optional ByVal pSuperscript As Boolean = True, _
                                            Optional ByVal pStart As Long = 1, _
                                            Optional ByVal pTimes As Long = 0) As String
On Error GoTo LBL_ERROR

    '------------------------------
    ' 引数の検証
    '------------------------------
    ' セルオブジェクトが設定されていなければ抜ける
    If pRng Is Nothing Then
        setSuperscriptForCharacters = "セルオブジェクトが設定されていません"
        Exit Function
    End If

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

    '------------------------------
    ' 検索文字列を含むセルを検索
    '------------------------------
    Dim rngFnd As Range
    Set rngFnd = pRng.Find(What:=pWhat, _
                           LookIn:=xlValues, _
                           SearchOrder:=xlByColumns, _
                           LookAt:=xlPart, _
                           MatchCase:=False, _
                           MatchByte:=False)

    ' 検索に一致するセルがなければ抜ける
    If rngFnd Is Nothing 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   ' 検索文字列の長さ格納用

    lngLen = Len(pWhat)
    strAddress = rngFnd.Address

    Do
        ' テキスト内の検索文字列に上付き・下付きを設定
        lngStart = pStart
        lngTimes = 0
        Do
            ' テキストを検索
            lngPos = InStr(lngStart, rngFnd.Value, pWhat, vbTextCompare)

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

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

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

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

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

        ' FindNext が Nothing を返した場合はループを抜ける
        If rngFnd Is Nothing Then Exit Do

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

'------------------------------
' エラー処理
'------------------------------
LBL_ERROR:
    setSuperscriptForCharacters = "エラー番号：" & Err.Number & vbLf & Err.Description
End Function