双击单元格，进行索引添色，谢谢liulang0808和cidanji老师！

lhj323323

liulang0808 发表于 2023-12-12 08:20
你贴的图片，显示不出来，是源文件报错的吗？附件上传看看吧

再次感谢版主老师！

cidanji

lhj323323 发表于 2023-12-12 08:15
谢谢老师回复

.Pattern = "汽车配件|新能源车|减速器"

好了

cidanji

lhj323323 发表于 2023-12-12 08:19
谢谢老师回复

2007之前版本不支持countlarge

liulang0808

lhj323323 发表于 2023-12-12 08:26
嗯，应该是版本问题。

没关系，我能搞明白问题所在，就足够了。

你的版本可以改成count属性就可以了，
不过在你的这个案例中，这一条可以不添加。
上次解决问题的时候，你也有同样的报错的

lhj323323

liulang0808 发表于 2023-12-12 12:08
你的版本可以改成count属性就可以了，
不过在你的这个案例中，这一条可以不添加。
上次解决问题的时候 ...

怎么改啊？

liulang0808

lhj323323 发表于 2023-12-12 14:32
怎么改啊？

If Target.CountLarge <> 1 Then Exit Sub这一行代码删除
或者改成If Target.Count <> 1 Then Exit Sub看看

lhj323323

liulang0808 发表于 2023-12-12 14:37
If Target.CountLarge  1 Then Exit Sub这一行代码删除
或者改成If Target.Count  1 Then Exit Sub看看

的确，或删或换，运行后的结果，都是正确的。
谢谢老师！

yizhimoshou

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    ' 如果选中的单元格数量不是1，退出子过程
    If Target.CountLarge <> 1 Then Exit Sub
   
    ' 如果选中的列不是第一列，退出子过程
    If Target.Column <> 1 Then Exit Sub
   
    ' 如果选中的行是第一行，退出子过程
    If Target.Row = 1 Then Exit Sub
   
    ' 如果选中单元格或相邻单元格内容为空，退出子过程
    If Len(Target) * Len(Target.Offset(0, 1)) = 0 Then Exit Sub
   
    ' 获取排序后的字符串
    Dim sortedString As String
    sortedString = GetSortedString(Target.Offset(0, 1).Value)
   
    ' 高亮匹配的单元格
    HighlightMatches sortedString
End Sub

Private Function GetSortedString(inputString As String) As String
    Dim result As String
   
    If InStr(inputString, ",") = 0 Then
        result = inputString
    Else
        Dim arr As Variant
        arr = Split(inputString, ",")
        For j = 0 To UBound(arr)
            For i = j + 1 To UBound(arr)
                If Len(arr(i)) > Len(arr(j)) Then
                    tm = arr(i)
                    arr(i) = arr(j)
                    arr(j) = tm
                End If
            Next i
        Next j
        result = Join(arr, "|")
    End If
   
    GetSortedString = result
End Function

Private Sub HighlightMatches(pattern As String)
    Application.ScreenUpdating = False
    Dim lastRow As Long
    lastRow = Cells(Rows.Count, 2).End(xlUp).Row
   
    Dim dataRange As Range
    Set dataRange = Range("B1:B" & lastRow)
   
    dataRange.Font.ColorIndex = 0
   
    With CreateObject("vbscript.regexp")
        .Pattern = pattern
        .Global = True
        For j = 2 To lastRow
            For Each match In .Execute(dataRange.Cells(j, 1).Value)
                dataRange.Cells(j, 1).Characters(match.FirstIndex + 1, match.Length).Font.ColorIndex = 3
            Next
        Next j
    End With
   
    Application.ScreenUpdating = True
End Sub