vba - 在 Excel 2010 中查找和替换而不丢失单元格格式 - 无法在包含 255 个字符的单元格上运行

Question

我在 Excel 2010 中使用这个宏来查找和替换单词而不会丢失单元格格式(例如，有些单词是粗体，有些是斜体，所以这个宏只是确保在替换单词时单元格保持相同的格式):

' Replacement of characters in the range(s) with storing of original Font
' Arguments:
'   Rng         - range for replacement
'   FindText    - string being searched for
'   ReplaceText - replacement string
'   MatchCase   - [False]/True, True to make the search case sensitive
Sub CharactersReplace(Rng As Range, FindText As String, ReplaceText As String, Optional MatchCase As Boolean)
  Dim i&, j&, jj&, k&, v$, m&, x As Range
  j = Len(FindText)
  jj = Len(ReplaceText)
  If Not MatchCase Then m = 1
  For Each x In Rng.Cells
    If VarType(x) = vbString Then
      k = 0
      i = 1
      With x
        v = .Value
        While i <= Len(v) - j + 1
          If StrComp(Mid$(v, i, j), FindText, m) = 0 Then
            .Characters(i + k, j).Insert ReplaceText
            k = k + jj - j
            i = i + j
          Else
            i = i + 1
          End If
        Wend
      End With
    End If
  Next
End Sub
' Testing subroutine
Sub Test_CharactersReplace()
  CharactersReplace Range("A743:F764"), "Replace This", "With This", True
End Sub

当我运行宏时，存在一个问题，即当单元格的字符超过 255 个时代码不起作用。

我一直在网上查找，但没有真正的解决方案!有谁知道如何解决这个问题？

Answer 1

编辑::

这不是一个简单的解决方案，但基本上你需要做的是:

获取一个数组，其中填充了单元格中每个字符的 FontStyle 值

使用 Replace 将“旧字符串”的每个实例替换为“新字符串”

移动数组中的值以反射(reflect)字符串长度的变化

将字符串和 Fontstyle 数组写回您的单元格

我设法创造了一些可行的东西，它有点长，但我不知道有任何其他方法可以做到这一点。

另外，请注意，这只需要/替换字体样式(粗体、斜体等)——它不会复制对颜色、大小、字体等的任何更改。不过，通过添加更多数组并设置/修改它们，这些可以很容易地合并现有循环内的值。

Public Sub RunTextChange()

Dim x as Range

For each x in Range("A743:F764")
    Call TextChange(x, "Replace This", "With This")
Next x

End Sub



Public Sub textchange(TargetCell As Range, FindTxt As String, ReplaceTxt As String)

''''Variables for text and length
Dim text1 As Variant: Dim text_length As Long
text1 = TargetCell.Value: text_length = Len(text1)

'variables for lengths of find/replace strings and difference
Dim strdiff As Long: Dim ftlen As Long: Dim rtlen As Long
ftlen = Len(FindTxt): rtlen = Len(ReplaceTxt): strdiff = rtlen - ftlen

'font arrays and loop integers
Dim fonts1 As Variant: Dim x As Long: Dim z As Long
Dim fonts2 As Variant
'set font array to length of string
ReDim fonts1(1 To text_length) As Variant
'make font array to correspond to the fontstyle of each character in the cell
For x = 1 To text_length
    fonts1(x) = TargetCell.Characters(Start:=x, Length:=1).Font.FontStyle
Next x

'detect first instance of find text- if not present, exit sub
z = InStr(text1, FindTxt)
If z = 0 Then Exit Sub

'continue loop as long as there are more instances of find string
Do While z > 0
'replace each instance of find string in turn (rather than all at once)
text1 = Left(text1, z - 1) & Replace(text1, FindTxt, ReplaceTxt, z, 1)

    'if no difference between find and replace string lengths, there is no need to amend the fonts array
    If Not strdiff = 0 Then
        'otherwise, expand fonts array and push values forward (or back, if the replace string is shorter)
        fonts2 = fonts1
        ReDim Preserve fonts1(1 To text_length + strdiff) As Variant
        For x = z + ftlen To text_length
            fonts1(x + strdiff) = fonts2(x)
        Next x
        'set all the letters in the replacement string to the same font as the first letter in the find string
        For x = z To z + rtlen - 1
            fonts1(x) = fonts2(z)
        Next x
    End If

    'change text_length to reflect new length of string
    text_length = Len(text1)
    'change z to search for next instance of find string - if none, will exit loop
    z = InStr(z + rtlen, text1, FindTxt)
Loop

'change cell Value to new string
TargetCell.Value = text1
'change all characters to new font styles
For x = 1 To text_length
    TargetCell.Characters(Start:=x, Length:=1).Font.FontStyle = fonts1(x)
Next x

End Sub