Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


4521 / 76732 ←次へ | 前へ→

【77832】Re:セル内の特定の文字列に囲まれた文字を上付き・下付きに置換したい
回答  ウッシ  - 16/1/8(金) 17:20 -

引用なし
パスワード
   こんにちは

<sup>・・・</sup>
<sub>・・・</sub>
が必ず対になっているとして、

Sub test()
  Dim r As Range
  Dim s As Long
  Dim u As Long
  Dim i As Long
  Dim j As Long
  Dim k As Long
  Dim p As String
  Dim t As String
  Dim s1 As Long
  Dim u1 As Long
  Dim v1()
  
  'A列とB列のデータ範囲を選択して実行
  
  For Each r In Selection
    t = ""
    i = 1: j = 0
    ReDim v1(1 To 2, 1 To 1)
    Do Until i > Len(r)
      p = Mid(r, i, Len(r))
      s = InStr(1, p, "<sub>")
      u = InStr(1, p, "<sup>")
      s1 = InStr(1, p, "</sub>")
      u1 = InStr(1, p, "</sup>")
      If s = 1 Or u = 1 Then
        j = j + 1
        ReDim Preserve v1(1 To 2, 1 To j)
      End If
      If s = 1 Then
        If s1 - s = 6 Then
          v1(1, j) = Len(t) + 1
          i = i + 5
          t = t & Mid(r, i, 1)
        Else
          i = i + 5
          For k = 0 To s1 - s - 6
            ReDim Preserve v1(1 To 2, 1 To j)
            v1(1, j) = Len(t) + 1
            t = t & Mid(r, i + k, 1)
            j = j + 1
          Next
          i = i + k - 1
        End If
      ElseIf u = 1 Then
        If u1 - u = 6 Then
          v1(1, j) = Len(t) + 1
          i = i + 5
          t = t & Mid(r, i, 1)
        Else
          i = i + 5
          For k = 0 To u1 - u - 6
            ReDim Preserve v1(1 To 2, 1 To j)
            v1(1, j) = Len(t) + 1
            t = t & Mid(r, i + k, 1)
            j = j + 1
          Next
          i = i + k - 1
        End If
      ElseIf s1 = 1 Then
        i = i + 6
        t = t & Mid(r, i, 1)
      ElseIf u1 = 1 Then
        i = i + 6
        t = t & Mid(r, i, 1)
      Else
        t = t & Mid(r, i, 1)
      End If
      i = i + 1
      s = 0
      u = 0
      s1 = 0
      u1 = 0
    Loop
    r.Value = t
    For i = 1 To UBound(v1, 2)
      If v1(1, i) <> "" Then
        r.Characters(Start:=v1(1, i), Length:=1).Font.Subscript = True
      ElseIf v1(2, i) <> "" Then
        r.Characters(Start:=v1(2, i), Length:=1).Font.Superscript = True
      End If
    Next
    r.WrapText = False
  Next
End Sub

で、うまく行くでしょうか?

3 hits

【77831】セル内の特定の文字列に囲まれた文字を上付き・下付きに置換したい 16/1/8(金) 14:58 質問[未読]
【77832】Re:セル内の特定の文字列に囲まれた文字を... ウッシ 16/1/8(金) 17:20 回答[未読]
【77833】Re:セル内の特定の文字列に囲まれた文字を... 16/1/8(金) 18:33 質問[未読]
【77834】Re:セル内の特定の文字列に囲まれた文字を... ウッシ 16/1/8(金) 18:49 回答[未読]
【77835】Re:セル内の特定の文字列に囲まれた文字を... 16/1/8(金) 19:18 お礼[未読]

4521 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free