|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Option Explicit
Sub TEST6()
Dim ar, i&, j&, strKey$, strJoin$, dic As Object, regEx As Object
Application.ScreenUpdating = False
Set dic = CreateObject("Scripting.Dictionary")
ar = Sheets(3).[B3].CurrentRegion.Value
For j = 1 To UBound(ar, 2)
If ar(1, j) = Empty Then ar(1, j) = ar(1, j - 1)
strKey = ar(1, j) & ar(2, j)
strJoin = ""
For i = 3 To UBound(ar)
If Len(ar(i, j)) Then strJoin = strJoin & "|" & ar(i, j)
Next i
dic(strKey) = Mid(strJoin, 2)
Next j
Set regEx = CreateObject("VBScript.RegExp")
With [A4].CurrentRegion
.Interior.Color = xlNone
ar = .Value
For j = 2 To UBound(ar, 2)
If ar(1, j) = Empty Then ar(1, j) = ar(1, j - 1)
strKey = ar(1, j) & ar(2, j)
If dic.exists(strKey) Then
If dic(strKey) <> "" Then
regEx.Pattern = dic(strKey)
For i = 3 To UBound(ar)
If regEx.test(ar(i, j)) Then .Cells(i, j).Interior.Color = vbYellow
Next i
End If
End If
Next j
End With
Set dic = Nothing
Application.ScreenUpdating = True
Beep
End Sub
|
|