Найти текст между двумя одинаковыми символами и изменить цвет шрифта

Question

Формат текста, с которым я имею дело, выглядит следующим образом:

| John | купил | яблоко |.

Цель состоит в том, чтобы найти весь текст между "|" (например, "Джон" и "яблоко"), изменить его цвет, а затем удалить оба "|".

Предполагается, что мой текущий код находит первый и второй экземпляры «|», go через каждый символ между двумя позициями, затем меняет цвет шрифта, удаляя оба «|» и я oop, чтобы сделать все это снова, пока нет "|" можно найти.

Моя проблема в том, что он часто удаляет и окрашивает неправильные символы. Я подозреваю, что это как-то связано с позициями символов, но я не знаю, где.

Соответствующий код выглядит так:

       Dim Cell As Range
       Dim iChr As Integer, N As Integer, Content As Integer
       Dim openPos As Long, Dim clsPos As Long
       Dim textBetween As String

       For Each Cell In ws.UsedRange' relevant code is going to loop through each cell of each sheet

            openPos = 0
            N = 1

         iChr = InStr(1, Cell.Value, "|")
         Do Until iChr = 0 'Loop until no "|"

            openPos = InStr(openPos + N, Cell, "|", vbTextCompare) 'first "|"
            clsPos = InStr(openPos + 1 + N, Cell, "|", vbTextCompare) 'second "|"

                For Content = openPos To clsPos
                    Cell.Characters(Content, 1).Font.Color = RGB(0, 255, 0)
                Next Content

            N = N + 1

            Cell.Characters(clsPos, 1).Delete 'delete first and second"|"
            Cell.Characters(openPos, 1).Delete

            iChr = InStr(1, Cell.Value, "^") 'check if there is any "|" left
         Loop

       Next Cell

Answer 1

Вот еще один подход с использованием коллекции

Sub Find_Location()

Dim iChr, StartChar, CharLen, i, j, k, m, n As Integer
Dim Ws As Worksheet
Set Ws = ActiveSheet
Dim Occurrence As Collection

    For Each Cell In Ws.UsedRange

        Set Occurrence = New Collection
        i = Len(Cell.Text)

        If i = 0 Then GoTo EndOfForLoop
            j = 1
            k = 0

            Do Until j > i
                iChr = InStr(j, Cell.Value, "|")

                If iChr = 1 Then
                    k = k + 1
                    Occurrence.Add iChr
                ElseIf iChr > 1 Then
                    k = k + 1
                    If Occurrence.Count = 0 Then
                        Occurrence.Add iChr
                    ElseIf Occurrence.Count > 0 Then
                        If (k / 2) = Int(k / 2) Then
                            Occurrence.Add (iChr - k)
                        ElseIf (k / 2) <> Int(k / 2) Then
                            Occurrence.Add (iChr - Occurrence.Count)
                        End If
                    End If
                ElseIf iChr = 0 Then
                    If k = 0 Then
                        GoTo EndOfForLoop
                    Else
                        GoTo ModifyContent
                    End If
                End If

                j = 1 + iChr
            Loop
ModifyContent:
        With Cell
        .Replace "|", ""
        End With

            m = 1
            n = 2
            Do Until n > k
                StartChar = Occurrence.Item(m)
                CharLen = (Occurrence.Item(n) - Occurrence.Item(m) + 1)
                With Cell.Characters(StartChar, CharLen)
                    .Font.Color = RGB(0, 255, 0)
                    .Font.Bold = True
                End With
                m = m + 2
                n = n + 2
            Loop
EndOfForLoop:
    Next
End Sub

Answer 2

Пожалуйста, попробуйте этот код.

Sub FindColorAndRemove()
    ' 016

    Const Marker As String = "|"                ' change to suit

    Dim Ws As Worksheet
    Dim Fnd As Range, FirstFound As String
    Dim Sp() As String
    Dim n As Integer
    Dim i As Integer

    For Each Ws In ActiveWorkbook.Worksheets
        ' enumerate exclusions here
        If Ws.CodeName <> Sheet1.CodeName Then
            Set Fnd = Ws.Cells.Find(What:=Marker & "*" & Marker, _
                   After:=Ws.Cells(1, 1), _
                   LookIn:=xlValues, _
                   LookAt:=xlPart, _
                   SearchDirection:=xlNext)
            If Not Fnd Is Nothing Then
                FirstFound = Fnd.Address
                Do
                    With Fnd
                        Sp = Split(.Value, Marker)
                        n = 0
                        .Value = Join(Sp, "")

                        For i = 0 To UBound(Sp) - 1
                            If i Mod 2 Then
                                With .Characters(n + 1, Len(Sp(i)))
                                    .Font.Color = vbRed
                                    .Font.Bold = True
                                End With
                            End If
                            n = n + Len(Sp(i))
                        Next i
                    End With

                    Set Fnd = Ws.Cells.FindNext
                    If Fnd Is Nothing Then Exit Do
                Loop While Fnd.Address <> FirstFound
            End If
        End If
    Next Ws
End Sub

Пожалуйста, обратите внимание на эту строку кода, If Ws.CodeName <> Sheet1.CodeName Then. Я добавил это, потому что я не хотел, чтобы все листы были включены. Вы можете использовать имя вкладки или кодовое имя. Я рекомендую CodeName , потому что пользователь с меньшей вероятностью изменит его. Если вам не нужна эта функция, вы можете использовать какой-то нерелевантный критерий или удалить весь оператор IF, включая его End If.