Найти и заменить текст, сохранить форматирование

Question

У меня есть файл Excel, который мне нужно найти и заменить, и ячейки уже имеют форматирование. Мне нужно сохранить форматирование. Когда я делаю обычный поиск и замену в Excel, это удаляет форматирование. Мне нужна помощь, чтобы сохранить форматирование. Я искал в Интернете и нашел ссылку ниже, но этот код не работает для меня.

Когда я пробую приведенный ниже код, эта строка в коде красная.

Call CharactersReplace(xRg, "<span style="background-color: #ffff00;">KK</span>", "<span style="background-color: #ffff00;">Kutools</span>", True)

Мне нужна помощь, чтобы исправить этот код и заставить его работать. Или, если есть более простой способ сделать это, пожалуйста, дайте мне знать.

https://www.extendoffice.com/documents/excel/3760-excel-find-and-replace-preserve-formatting.html

Sub CharactersReplace(Rng As Range, FindText As String, ReplaceText As String, Optional MatchCase As Boolean = False)
  'UpdatebyExtendoffice20160711
    Dim I As Long
    Dim xLenFind As Long
    Dim xLenRep As Long
    Dim K As Long
    Dim xValue As String
    Dim M As Long
    Dim xCell As Range
    xLenFind = Len(FindText)
    xLenRep = Len(ReplaceText)
    If Not MatchCase Then M = 1
    For Each xCell In Rng
        If VarType(xCell) = vbString Then
            xValue = xCell.Value
            K = 0
            For I = 1 To Len(xValue)
              If StrComp(Mid$(xValue, I, xLenFind), FindText, M) = 0 Then
                xCell.Characters(I + K, xLenFind).Insert ReplaceText
                K = K + xLenRep - xLenFind
              End If
            Next
        End If
    Next
End Sub

Sub Test_CharactersReplace()
    Dim xRg As Range
    Dim xTxt As String
    Dim xCell As Range
    On Error Resume Next
    If ActiveWindow.RangeSelection.Count > 1 Then
      xTxt = ActiveWindow.RangeSelection.AddressLocal
    Else
      xTxt = ActiveSheet.UsedRange.AddressLocal
    End If
    Set xRg = Application.InputBox("Select a range:", "Kutools for Excel", xTxt, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    Call CharactersReplace(xRg, "<span style="background-color: #ffff00;">KK</span>", "<span style="background-color: #ffff00;">Kutools</span>", True)
End Sub

Answer 1

Я ценю то, что узнал из комментария от @ Mar c, но после попытки отредактировать xml я обнаружил, что это было слишком сложно. Любая небольшая ошибка, которую я сделал, сделала файл xml недоступным для Excel.

Таким образом, мое решение заключалось в том, чтобы скопировать лист в Word (он представляет собой таблицу Word), используя функции расширенного поиска и замены Word, а затем вставить таблицу обратно в лист Excel. Это сработало для меня.

Поскольку у меня было много листов, с которыми я хотел сделать это, я сделал эту процедуру VBA. После копирования моих данных (в первых 2 столбцах) в Word, он удаляет все символы надстрочного индекса, а также выполняет необходимое форматирование. Не очень, но это помогло мне сделать 72 листа, сэкономив много утомительной работы.

Sub ExcelSheetsEditedViaWord()
' note: must add a reference to the Word-library (Microsoft Word 16.0 Object Lilbrary)
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim s As String, i As Integer, sh As Worksheet, r As Range
  Application.DisplayStatusBar = True
  Application.StatusBar = "Opening Word  ..."
  Set wrdApp = CreateObject("Word.Application")
  wrdApp.Visible = True
  Set wrdDoc = wrdApp.Documents.Add
  With ActiveDocument.PageSetup
    .PageWidth = InchesToPoints(11)
    .PageHeight = InchesToPoints(22)
  End With
  wrdApp.ActiveWindow.ActivePane.View.Zoom.Percentage = 40
  i = 0
  For Each sh In ThisWorkbook.Worksheets
    Set r = sh.Range("A1:B1")
    Set r = sh.Range(r, r.End(xlDown))
    r.Copy
    'wait to avoid error that sometimes stops code.
    Application.Wait (Now + TimeValue("0:00:01"))
    wrdDoc.Range.PasteExcelTable False, False, False
    sh.Activate
    sh.Range("A1").Select
    With wrdApp.Selection
      .Find.ClearFormatting
      With .Find.Font
        .Superscript = True
        .Subscript = False
      End With
    .Find.Replacement.ClearFormatting
      With .Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
      End With
    .Find.Execute Replace:=wdReplaceAll
    .WholeStory
    .Cut
    'wait some second to try to avoid error that stops code. However,
    'even when code stops, hitting debug allows it to continue
    Application.Wait (Now + TimeValue("0:00:06"))
    sh.Paste
    With sh.Columns("A:B")
      .VerticalAlignment = xlTop
      .WrapText = True
      .Font.Name = "Times New Roman"
      .Font.Size = 16
    End With
    i = i + 1
    End With
    Application.StatusBar = i & " sheets done"
  Next sh
  wrdApp.Quit False ' close the Word application
  Set wrdDoc = Nothing
  Set wrdApp = Nothing
  MsgBox i & " sheets of the workbook processed"
End Sub

У меня есть несколько операторов Application.Wait(), в которых код иногда может завершаться сбоем - то, что я часто видел в коде, который копирует / вставляет между Excel и Word. Но когда это терпит неудачу, нажимая отладку и продолжая работать каждый раз. Как я уже сказал, не красиво, но выполняет свою работу.