Find text between two identical characters and change its font color

Question

The format of the text I'm dealing with looks like this:

|John| bought an |apple|.

The goal is to find all the text between "|"(like "John" and "apple"), change its color then delete both "|".

My current code is supposed to find the first and second instances of "|", go through each character between the two positions then change its font color, deleting both "|" and loop to do the whole thing again until no "|" can be found.

My problem is it often delete and color the wrong characters. I suspect it has something to do with character positions, but I don't know where.

Relevant code looks like this:

       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

Please try this code.

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

Please pay attention to this line of code, If Ws.CodeName <> Sheet1.CodeName Then . I added it because I didn't want all sheets to be included. You can use the worksheets' tab name or code name. I recommend the CodeName because the user is less likely to change it. If you don't need the feature you can use some irrelevant criterium or delete the entire IF statement, including its End If.

Answer 2

Here is another approach using Collection

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