用 Excel sheet 中的 HTML 标签替换上标和斜体
Replace superscript and italic with HTML tags in Excel sheet
我需要去掉上标和斜体，添加一个 HTML 标签来包围 word/letter。
例如：
我的短语有一个上标1，还有一个斜体字。
应转换为：
My phrase has a superscript<sup>1</sup> and also has an <i>italic</i> word.
我找到了一个 "solution"（它定位上标和斜体所在的位置并存储它的位置），但它有很多问题。我得让它工作一段时间：
Sub TagSubstitution()
Dim lngStart_i As Long
Dim lngFinish_i As Long
Dim lngStart_sup As Long
Dim lngFinish_sup As Long
Dim n As Long
Dim k_i As Long
Dim k_sup As Long
Dim rngCell As Range
Dim rngConstants As Range
Dim cellAddress As String
On Error Resume Next
Set rngConstants = ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not rngConstants Is Nothing Then
Application.ScreenUpdating = False
For Each rngCell In rngConstants.Cells
Dim listStart_i() As Long, X_i As Long
Dim listFinish_i() As Long, Y_i As Long
Dim listStart_sup() As Long, X_sup As Long
Dim listFinish_sup() As Long, Y_sup As Long
X_i = 0
Y_i = 0
X_sup = 0
Y_sup = 0
ReDim Preserve listStart_i(X)
ReDim Preserve listFinish_i(Y)
ReDim Preserve listStart_sup(X)
ReDim Preserve listFinish_sup(Y)
lngStart_i = 0
lngStart_sup = 0
For n = 1 To Len(rngCell.Value) + 1
If rngCell.Characters(n, 1).Font.Italic Then
If lngStart_i = 0 Then
lngStart_i = n
ReDim Preserve listStart_i(0 To X_i)
listStart_i(X_i) = lngStart_i
X_i = X_i + 1
End If
ElseIf lngStart_i <> 0 Then
If Not rngCell.Characters(n, 1).Font.Italic Then
lngFinish_i = n
ReDim Preserve listFinish_i(0 To Y_i)
listFinish_i(Y_i) = lngFinish_i
Y_i = Y_i + 1
lngStart_i = 0
End If
End If
If rngCell.Characters(n, 1).Font.Superscript Then
If lngStart_sup = 0 Then
lngStart_sup = n
ReDim Preserve listStart_sup(0 To X_sup)
listStart_sup(X_sup) = lngStart_sup
X_sup = X_sup + 1
End If
ElseIf lngStart_sup <> 0 Then
If Not rngCell.Characters(n, 1).Font.Superscript Then
lngFinish_sup = n
ReDim Preserve listFinish_sup(0 To Y_sup)
listFinish_sup(Y_sup) = lngFinish_sup
Y_sup = Y_sup + 1
lngStart_sup = 0
End If
End If
Next n
If listStart_i(0) <> 0 Then
Dim sup_addition_i As Integer
sup_addition_i = 0
For k_i = LBound(listStart_i) To UBound(listStart_i)
start_value = listStart_i(k_i) + sup_addition_i
finish_value = listFinish_i(k_i) + sup_addition_i
If Len(rngCell.Value) > 255 Then
content_len = finish_value + 1 - start_value
before_content = Left(rngCell, start_value - 1)
after_content = Right(rngCell, Len(rngCell.Value) + content_len - finish_value)
after_content = Left(after_content, content_len - 1)
end_content = Right(rngCell, Len(rngCell.Value) + 1 - finish_value)
rngCell = before_content & "<i>" & after_content & "</i>" & end_content
Else
rngCell.Characters(start_value, 0).Insert "<i>"
rngCell.Characters(finish_value + 3, 0).Insert "</i>"
End If
sup_addition_i = 7 * (k_i + 1)
Next k_i
rngCell.Font.Italic = False
If listStart_sup(0) <> 0 Then
Dim sup_addition_sup As Integer
sup_addition_p = 0 - sup_addition_i
For k_sup = LBound(listStart_sup) To UBound(listStart_sup)
start_value = listStart_sup(k_sup) + sup_addition_sup
finish_value = listFinish_sup(k_sup) + sup_addition_sup
If Len(rngCell.Value) > 255 Then
content_len = finish_value + 1 - start_value
before_content = Left(rngCell, start_value - 1)
after_content = Right(rngCell, Len(rngCell.Value) + content_len - finish_value)
after_content = Left(after_content, content_len - 1)
end_content = Right(rngCell, Len(rngCell.Value) + 1 - finish_value)
rngCell = before_content & "<sup>" & after_content & "</sup>" & end_content
Else
rngCell.Characters(start_value, 0).Insert "<sup>"
rngCell.Characters(finish_value + 5, 0).Insert "</sup>"
End If
sup_addition_sup = 11 * (k_sup + 1) - sup_addition_i
Next k_sup
rngCell.Font.Superscript = False
End If
End If
Next rngCell
Application.ScreenUpdating = True
End If
End Sub
此代码的问题是，当我在同一个单元格上同时使用上标和斜体时，我遇到的问题是，在插入斜体后，上标的位置与以前不同。所以在那之后我放错了每个 <sup> 标签...
我是 VBA 的新手，我不知道完成此解决方案的正确方法。
编辑
我尝试过的另一种方法：
Sub AdicionarTags()
Dim xSh As Worksheet
Application.ScreenUpdating = False
For Each xSh In Worksheets
xSh.Select
Call TagItalic
Call TagSuperscript
Next
Application.ScreenUpdating = True
End Sub
Sub TagItalic()
Dim lngStart As Long
Dim lngFinish As Long
Dim n As Long
Dim k As Long
Dim rngCell As Range
Dim rngConstants As Range
Dim cellAddress As String
On Error Resume Next
Set rngConstants = ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not rngConstants Is Nothing Then
Application.ScreenUpdating = False
For Each rngCell In rngConstants.Cells
Dim listStart() As Long, X As Long
Dim listFinish() As Long, Y As Long
X = 0
Y = 0
ReDim Preserve listStart(X)
ReDim Preserve listFinish(Y)
lngStart = 0
For n = 1 To Len(rngCell.Value) + 1
If rngCell.Characters(n, 1).Font.Italic Then
If lngStart = 0 Then
lngStart = n
ReDim Preserve listStart(0 To X)
listStart(X) = lngStart
X = X + 1
End If
ElseIf lngStart <> 0 Then
If Not rngCell.Characters(n, 1).Font.Italic Then
lngFinish = n
ReDim Preserve listFinish(0 To Y)
listFinish(Y) = lngFinish
Y = Y + 1
lngStart = 0
End If
End If
Next n
If listStart(0) <> 0 Then
Dim sup_addition As Integer
sup_addition = 0
For k = LBound(listStart) To UBound(listStart)
start_value = listStart(k) + sup_addition
finish_value = listFinish(k) + sup_addition
content_len = finish_value + 1 - start_value
before_content = Left(rngCell, start_value - 1)
after_content = Right(rngCell, Len(rngCell.Value) + content_len - finish_value)
after_content = Left(after_content, content_len - 1)
end_content = Right(rngCell, Len(rngCell.Value) + 1 - finish_value)
rngCell = before_content & "<i>" & after_content & "</i>" & end_content
sup_addition = 7 * (k + 1)
Next k
rngCell.Font.Italic = False
End If
Next rngCell
Application.ScreenUpdating = True
End If
End Sub
Sub TagSuperscript()
Dim lngStart As Long
Dim lngFinish As Long
Dim n As Long
Dim k As Long
Dim rngCell As Range
Dim rngConstants As Range
Dim cellAddress As String
On Error Resume Next
Set rngConstants = ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not rngConstants Is Nothing Then
Application.ScreenUpdating = False
For Each rngCell In rngConstants.Cells
Dim listStart() As Long, X As Long
Dim listFinish() As Long, Y As Long
X = 0
Y = 0
ReDim Preserve listStart(X)
ReDim Preserve listFinish(Y)
lngStart = 0
For n = 1 To Len(rngCell.Value) + 1
If rngCell.Characters(n, 1).Font.Superscript Then
If lngStart = 0 Then
lngStart = n
ReDim Preserve listStart(0 To X)
listStart(X) = lngStart
X = X + 1
End If
ElseIf lngStart <> 0 Then
If Not rngCell.Characters(n, 1).Font.Superscript Then
lngFinish = n
ReDim Preserve listFinish(0 To Y)
listFinish(Y) = lngFinish
Y = Y + 1
lngStart = 0
End If
End If
Next n
If listStart(0) <> 0 Then
Dim sup_addition As Integer
sup_addition = 0
For k = LBound(listStart) To UBound(listStart)
start_value = listStart(k) + sup_addition
finish_value = listFinish(k) + sup_addition
content_len = finish_value + 1 - start_value
before_content = Left(rngCell, start_value - 1)
after_content = Right(rngCell, Len(rngCell.Value) + content_len - finish_value)
after_content = Left(after_content, content_len - 1)
end_content = Right(rngCell, Len(rngCell.Value) + 1 - finish_value)
rngCell = before_content & "<sup>" & after_content & "</sup>" & end_content
sup_addition = 11 * (k + 1)
Next k
rngCell.Font.Superscript = False
End If
Next rngCell
Application.ScreenUpdating = True
End If
End Sub
但这次的问题是，在 运行 第一个 Sub 之后，当我替换单元格时，样式丢失了，当第二个函数运行时，它有 none 的以前的格式。
与其插入您的字符串，不如开始构建一个合适的字符串 (z)，类似于：
Option Explicit
Sub remove_italics_and_superscripts()
Dim i As Long, j As Long, rng As Range, z As String
For Each rng In ActiveSheet.UsedRange
For i = 1 To Len(rng)
If rng.Characters(i, 1).Font.Superscript = True Then
For j = 0 To Len(rng) - i
If rng.Characters(j + i, 1).Font.Superscript = False Then Exit For
Next j
z = z & "<sup>" & Mid(rng.Value, i, j) & "</sup>"
ElseIf rng.Characters(i, 1).Font.Italic = True Then
For j = 0 To Len(rng) - i
If rng.Characters(j + i, 1).Font.Italic = False Then Exit For
Next j
z = z & "<i>" & Mid(rng.Value, i, j) & "</i>"
Else
z = z & Mid(rng.Value, i, 1)
j = 1
End If
i = i + j - 1
Next i
rng.Offset(, 1).Value = z 'didn't immediately see where you output, so just out to the next column to the right
z = ""
Next rng
End Sub
我清理了一些您使用的 looping/conditions。此外，这消除了对数组的需要（注意你的redim preserve）。
我需要去掉上标和斜体，添加一个 HTML 标签来包围 word/letter。
例如：
我的短语有一个上标1，还有一个斜体字。
应转换为：
My phrase has a superscript<sup>1</sup> and also has an <i>italic</i> word.
我找到了一个 "solution"（它定位上标和斜体所在的位置并存储它的位置），但它有很多问题。我得让它工作一段时间：
Sub TagSubstitution()
Dim lngStart_i As Long
Dim lngFinish_i As Long
Dim lngStart_sup As Long
Dim lngFinish_sup As Long
Dim n As Long
Dim k_i As Long
Dim k_sup As Long
Dim rngCell As Range
Dim rngConstants As Range
Dim cellAddress As String
On Error Resume Next
Set rngConstants = ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not rngConstants Is Nothing Then
Application.ScreenUpdating = False
For Each rngCell In rngConstants.Cells
Dim listStart_i() As Long, X_i As Long
Dim listFinish_i() As Long, Y_i As Long
Dim listStart_sup() As Long, X_sup As Long
Dim listFinish_sup() As Long, Y_sup As Long
X_i = 0
Y_i = 0
X_sup = 0
Y_sup = 0
ReDim Preserve listStart_i(X)
ReDim Preserve listFinish_i(Y)
ReDim Preserve listStart_sup(X)
ReDim Preserve listFinish_sup(Y)
lngStart_i = 0
lngStart_sup = 0
For n = 1 To Len(rngCell.Value) + 1
If rngCell.Characters(n, 1).Font.Italic Then
If lngStart_i = 0 Then
lngStart_i = n
ReDim Preserve listStart_i(0 To X_i)
listStart_i(X_i) = lngStart_i
X_i = X_i + 1
End If
ElseIf lngStart_i <> 0 Then
If Not rngCell.Characters(n, 1).Font.Italic Then
lngFinish_i = n
ReDim Preserve listFinish_i(0 To Y_i)
listFinish_i(Y_i) = lngFinish_i
Y_i = Y_i + 1
lngStart_i = 0
End If
End If
If rngCell.Characters(n, 1).Font.Superscript Then
If lngStart_sup = 0 Then
lngStart_sup = n
ReDim Preserve listStart_sup(0 To X_sup)
listStart_sup(X_sup) = lngStart_sup
X_sup = X_sup + 1
End If
ElseIf lngStart_sup <> 0 Then
If Not rngCell.Characters(n, 1).Font.Superscript Then
lngFinish_sup = n
ReDim Preserve listFinish_sup(0 To Y_sup)
listFinish_sup(Y_sup) = lngFinish_sup
Y_sup = Y_sup + 1
lngStart_sup = 0
End If
End If
Next n
If listStart_i(0) <> 0 Then
Dim sup_addition_i As Integer
sup_addition_i = 0
For k_i = LBound(listStart_i) To UBound(listStart_i)
start_value = listStart_i(k_i) + sup_addition_i
finish_value = listFinish_i(k_i) + sup_addition_i
If Len(rngCell.Value) > 255 Then
content_len = finish_value + 1 - start_value
before_content = Left(rngCell, start_value - 1)
after_content = Right(rngCell, Len(rngCell.Value) + content_len - finish_value)
after_content = Left(after_content, content_len - 1)
end_content = Right(rngCell, Len(rngCell.Value) + 1 - finish_value)
rngCell = before_content & "<i>" & after_content & "</i>" & end_content
Else
rngCell.Characters(start_value, 0).Insert "<i>"
rngCell.Characters(finish_value + 3, 0).Insert "</i>"
End If
sup_addition_i = 7 * (k_i + 1)
Next k_i
rngCell.Font.Italic = False
If listStart_sup(0) <> 0 Then
Dim sup_addition_sup As Integer
sup_addition_p = 0 - sup_addition_i
For k_sup = LBound(listStart_sup) To UBound(listStart_sup)
start_value = listStart_sup(k_sup) + sup_addition_sup
finish_value = listFinish_sup(k_sup) + sup_addition_sup
If Len(rngCell.Value) > 255 Then
content_len = finish_value + 1 - start_value
before_content = Left(rngCell, start_value - 1)
after_content = Right(rngCell, Len(rngCell.Value) + content_len - finish_value)
after_content = Left(after_content, content_len - 1)
end_content = Right(rngCell, Len(rngCell.Value) + 1 - finish_value)
rngCell = before_content & "<sup>" & after_content & "</sup>" & end_content
Else
rngCell.Characters(start_value, 0).Insert "<sup>"
rngCell.Characters(finish_value + 5, 0).Insert "</sup>"
End If
sup_addition_sup = 11 * (k_sup + 1) - sup_addition_i
Next k_sup
rngCell.Font.Superscript = False
End If
End If
Next rngCell
Application.ScreenUpdating = True
End If
End Sub
此代码的问题是，当我在同一个单元格上同时使用上标和斜体时，我遇到的问题是，在插入斜体后，上标的位置与以前不同。所以在那之后我放错了每个 <sup> 标签...
我是 VBA 的新手，我不知道完成此解决方案的正确方法。
编辑
我尝试过的另一种方法：
Sub AdicionarTags()
Dim xSh As Worksheet
Application.ScreenUpdating = False
For Each xSh In Worksheets
xSh.Select
Call TagItalic
Call TagSuperscript
Next
Application.ScreenUpdating = True
End Sub
Sub TagItalic()
Dim lngStart As Long
Dim lngFinish As Long
Dim n As Long
Dim k As Long
Dim rngCell As Range
Dim rngConstants As Range
Dim cellAddress As String
On Error Resume Next
Set rngConstants = ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not rngConstants Is Nothing Then
Application.ScreenUpdating = False
For Each rngCell In rngConstants.Cells
Dim listStart() As Long, X As Long
Dim listFinish() As Long, Y As Long
X = 0
Y = 0
ReDim Preserve listStart(X)
ReDim Preserve listFinish(Y)
lngStart = 0
For n = 1 To Len(rngCell.Value) + 1
If rngCell.Characters(n, 1).Font.Italic Then
If lngStart = 0 Then
lngStart = n
ReDim Preserve listStart(0 To X)
listStart(X) = lngStart
X = X + 1
End If
ElseIf lngStart <> 0 Then
If Not rngCell.Characters(n, 1).Font.Italic Then
lngFinish = n
ReDim Preserve listFinish(0 To Y)
listFinish(Y) = lngFinish
Y = Y + 1
lngStart = 0
End If
End If
Next n
If listStart(0) <> 0 Then
Dim sup_addition As Integer
sup_addition = 0
For k = LBound(listStart) To UBound(listStart)
start_value = listStart(k) + sup_addition
finish_value = listFinish(k) + sup_addition
content_len = finish_value + 1 - start_value
before_content = Left(rngCell, start_value - 1)
after_content = Right(rngCell, Len(rngCell.Value) + content_len - finish_value)
after_content = Left(after_content, content_len - 1)
end_content = Right(rngCell, Len(rngCell.Value) + 1 - finish_value)
rngCell = before_content & "<i>" & after_content & "</i>" & end_content
sup_addition = 7 * (k + 1)
Next k
rngCell.Font.Italic = False
End If
Next rngCell
Application.ScreenUpdating = True
End If
End Sub
Sub TagSuperscript()
Dim lngStart As Long
Dim lngFinish As Long
Dim n As Long
Dim k As Long
Dim rngCell As Range
Dim rngConstants As Range
Dim cellAddress As String
On Error Resume Next
Set rngConstants = ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not rngConstants Is Nothing Then
Application.ScreenUpdating = False
For Each rngCell In rngConstants.Cells
Dim listStart() As Long, X As Long
Dim listFinish() As Long, Y As Long
X = 0
Y = 0
ReDim Preserve listStart(X)
ReDim Preserve listFinish(Y)
lngStart = 0
For n = 1 To Len(rngCell.Value) + 1
If rngCell.Characters(n, 1).Font.Superscript Then
If lngStart = 0 Then
lngStart = n
ReDim Preserve listStart(0 To X)
listStart(X) = lngStart
X = X + 1
End If
ElseIf lngStart <> 0 Then
If Not rngCell.Characters(n, 1).Font.Superscript Then
lngFinish = n
ReDim Preserve listFinish(0 To Y)
listFinish(Y) = lngFinish
Y = Y + 1
lngStart = 0
End If
End If
Next n
If listStart(0) <> 0 Then
Dim sup_addition As Integer
sup_addition = 0
For k = LBound(listStart) To UBound(listStart)
start_value = listStart(k) + sup_addition
finish_value = listFinish(k) + sup_addition
content_len = finish_value + 1 - start_value
before_content = Left(rngCell, start_value - 1)
after_content = Right(rngCell, Len(rngCell.Value) + content_len - finish_value)
after_content = Left(after_content, content_len - 1)
end_content = Right(rngCell, Len(rngCell.Value) + 1 - finish_value)
rngCell = before_content & "<sup>" & after_content & "</sup>" & end_content
sup_addition = 11 * (k + 1)
Next k
rngCell.Font.Superscript = False
End If
Next rngCell
Application.ScreenUpdating = True
End If
End Sub
但这次的问题是，在 运行 第一个 Sub 之后，当我替换单元格时，样式丢失了，当第二个函数运行时，它有 none 的以前的格式。
与其插入您的字符串，不如开始构建一个合适的字符串 (z)，类似于：
Option Explicit
Sub remove_italics_and_superscripts()
Dim i As Long, j As Long, rng As Range, z As String
For Each rng In ActiveSheet.UsedRange
For i = 1 To Len(rng)
If rng.Characters(i, 1).Font.Superscript = True Then
For j = 0 To Len(rng) - i
If rng.Characters(j + i, 1).Font.Superscript = False Then Exit For
Next j
z = z & "<sup>" & Mid(rng.Value, i, j) & "</sup>"
ElseIf rng.Characters(i, 1).Font.Italic = True Then
For j = 0 To Len(rng) - i
If rng.Characters(j + i, 1).Font.Italic = False Then Exit For
Next j
z = z & "<i>" & Mid(rng.Value, i, j) & "</i>"
Else
z = z & Mid(rng.Value, i, 1)
j = 1
End If
i = i + j - 1
Next i
rng.Offset(, 1).Value = z 'didn't immediately see where you output, so just out to the next column to the right
z = ""
Next rng
End Sub
我清理了一些您使用的 looping/conditions。此外，这消除了对数组的需要（注意你的redim preserve）。