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

EDIT ::

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

获取一个数组，其中包含单元格中每个字符的FontStyle的值
使用替换来替换＆＃34;旧字符串的每个实例＆＃34;使用您的＆＃34;新字符串＆＃34;
移动数组中的值以反映字符串长度的变化
将字符串和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

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

1 个答案: