[英]Find text between two identical characters and change its font color
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 "|".目标是找到“|”之间的所有文本(如“John”和“apple”),更改其颜色然后删除两个“|”。
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 "|"我当前的代码应该通过两个位置之间的每个字符找到“|”的第一个和第二个实例 go 然后更改其字体颜色,删除两个“|” 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
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
.请注意这行代码
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.
我推荐CodeName ,因为用户不太可能更改它。 If you don't need the feature you can use some irrelevant criterium or delete the entire IF statement, including its End If.
如果您不需要该功能,您可以使用一些不相关的标准或删除整个 IF 语句,包括其 End If。
Here is another approach using Collection这是使用 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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.