Excel高亮部分字符串

最新推荐文章于 2022-04-22 11:15:56 发布

dcw0402

最新推荐文章于 2022-04-22 11:15:56 发布

阅读量868

点赞数 1

分类专栏：娱乐

本文链接：https://blog.csdn.net/dcw0402/article/details/104546899

版权

娱乐专栏收录该内容

16 篇文章 1 订阅

订阅专栏

Sub subHighLightKeyText(ByRef objRg As Range, ByVal key$, ByRef colorValue&)
    Dim sh As Worksheet, str$, startPos%, setLen%, nextFindStart%, rg As Range

    setLen = VBA.Len(key)
    For Each rg In objRg
        str = rg.Text
        nextFindStart = 1
        startPos = VBA.InStr(nextFindStart, str, key, vbTextCompare)

        While startPos > 0
            rg.Characters(Start:=startPos, Length:=setLen).Font.Color = colorValue
            nextFindStart = startPos + setLen
            startPos = VBA.InStr(nextFindStart, str, key, vbTextCompare)
        Wend
    Next
End Sub

Sub setHighLightKeyText()
    Dim key$, ibRet, arr() As String, lColor&, rg As Range
    Dim str$

    str = "format:key,[highlightColor],[atRange]" & VBA.Chr(13) & VBA.Chr(10)
    str = str & "highlightColor:r->red, g->green, b->blue" & VBA.Chr(13) & VBA.Chr(10)
    str = str & "atRange:u->used range on current sheet, s->selected range on current sheet" & VBA.Chr(13) & VBA.Chr(10)
    str = str & "[highlightColor][atRange] can be omitted. Default value is used when omitted." & VBA.Chr(13) & VBA.Chr(10)
    str = str & "highlightColor default:r, atRange default:u" & VBA.Chr(13) & VBA.Chr(10) & VBA.Chr(13) & VBA.Chr(10)
    
    str = str & "example:mykey" & VBA.Chr(13) & VBA.Chr(10)
    str = str & "example:mykey,rb" & VBA.Chr(13) & VBA.Chr(10)
    str = str & "example:mykey,rb,s" & VBA.Chr(13) & VBA.Chr(10)
    str = str & "example:mykey,,s" & VBA.Chr(13) & VBA.Chr(10)
    
    'set default value
    Set rg = ActiveSheet.UsedRange
    lColor = VBA.RGB(255, 0, 0) 'red
    
    ibRet = VBA.InputBox(str, "input param", "")
    If ibRet = "" Then MsgBox "param err", vbCritical + vbOKOnly, "Error": Exit Sub
    arr = VBA.Split(ibRet, ",")

    If UBound(arr) >= 3 Then
        MsgBox "param count > 3", vbCritical + vbOKOnly, "Error": Exit Sub
    End If
    
    key = arr(0)
    If UBound(arr) >= 1 Then
        lColor = 0
        If VBA.InStr(1, arr(1), "r", vbTextCompare) > 0 Then
            lColor = lColor + VBA.RGB(255, 0, 0)
        End If
        If VBA.InStr(1, arr(1), "g", vbTextCompare) > 0 Then
            lColor = lColor + VBA.RGB(0, 255, 0)
        End If
        If VBA.InStr(1, arr(1), "b", vbTextCompare) > 0 Then
            lColor = lColor + VBA.RGB(0, 0, 255)
        End If
    End If
    If UBound(arr) >= 2 Then
        If arr(2) = "s" Then
            Set rg = Selection
        End If
    End If
    Call subHighLightKeyText(rg, key, lColor)
End Sub