| |
こんにちは
<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
で、うまく行くでしょうか？
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
