从段落中搜索一系列单词

Question

我有一个单词列表。如果匹配，我想在段落中标记该单词。如果单词匹配然后想改变颜色。

我正在尝试这段代码：

Sub HighlightStrings()
Application.ScreenUpdating = False
Dim rng As Range
Dim InputRang As Range
Dim cFnd As String
Dim xTmp As String
Dim x As Long
Dim celValue As String
Dim m As Long
Dim y As Long
Dim xFNum As Integer
Dim xArrFnd As Variant
Dim xStr As String

celValue = Range("A1").Value
cFnd = celValue
If Len(cFnd) < 1 Then Exit Sub
xArrFnd = Split(cFnd, ";")
For Each rng In Selection
With rng
For xFNum = 0 To UBound(xArrFnd)
xStr = xArrFnd(xFNum)
y = Len(xStr)
m = UBound(Split(rng.Value, xStr))
If m > 0 Then
xTmp = ""
For x = 0 To m - 1
xTmp = xTmp & Split(rng.Value, xStr)(x)
.Characters(Start:=Len(xTmp) + 1, Length:=y).Font.ColorIndex = 3
.Characters(Start:=Len(xTmp) + 1, Length:=y).Font.Bold = True
xTmp = xTmp & xStr
Next
End If
Next xFNum
End With
Next rng
Application.ScreenUpdating = True
End Sub

但是这个代码得到一个字。我需要用分号分隔的单词范围。 例如， "你好；段落；粗体；单词"

Answer 1

我自己解决我的问题。需要添加这段代码：

Dim arr
    arr = Join(Application.Transpose(Range("A1:A4").Value), ";")

完整代码：

Sub HighlightStrings()
Application.ScreenUpdating = False
Dim rng As Range
Dim InputRang As Range
Dim cFnd As String
Dim xTmp As String
Dim x As Long
Dim m As Long
Dim y As Long
Dim xFNum As Integer
Dim xArrFnd As Variant
Dim xStr As String
Dim arr

arr = Join(Application.Transpose(Range("A1:A4").Value), ";")
cFnd = arr

If Len(cFnd) < 1 Then Exit Sub
xArrFnd = Split(cFnd, ";")
    For Each rng In Selection
        With rng
            For xFNum = 0 To UBound(xArrFnd)
            xStr = xArrFnd(xFNum)
            y = Len(xStr)
            m = UBound(Split(rng.Value, xStr))
                If m > 0 Then
                xTmp = ""
                    For x = 0 To m - 1
                    xTmp = xTmp & Split(rng.Value, xStr)(x)
                    .Characters(Start:=Len(xTmp) + 1, Length:=y).Font.ColorIndex = 3
                    .Characters(Start:=Len(xTmp) + 1, Length:=y).Font.Bold = True
                    xTmp = xTmp & xStr
                    Next
                End If
            Next xFNum
        End With
    Next rng
Application.ScreenUpdating = True
End Sub