依次查询H列内容和J列内容对比，如果含有8位数相同，那么单元格背景变成黄色

JUMU

2025/08/21 15:39:52

Excel VBA 编程：依次查询H列内容和J列内容对比，如果含有8位数相同，那么单元格背景变成黄色。

Sub HighlightMatching8Digits()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim hValue As String, jValue As String
Dim hDigits As Collection, jDigits As Collection
Dim digit As Variant
' 设置当前工作表
Set ws = ActiveSheet
' 获取最后一行数据
lastRow = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row
' 循环处理每一行
For i = 1 To lastRow
' 重置背景色
ws.Cells(i, "H").Interior.ColorIndex = xlNone
ws.Cells(i, "J").Interior.ColorIndex = xlNone
' 获取单元格值
hValue = CStr(ws.Cells(i, "H").Value)
jValue = CStr(ws.Cells(i, "J").Value)
' 提取H列中的所有8位数字
Set hDigits = Get8DigitNumbers(hValue)
' 提取J列中的所有8位数字
Set jDigits = Get8DigitNumbers(jValue)
' 检查是否有相同的8位数字
If HasCommonItem(hDigits, jDigits) Then
' 如果有相同的8位数字，设置背景色为黄色
ws.Cells(i, "H").Interior.Color = vbYellow
ws.Cells(i, "J").Interior.Color = vbYellow
End If
Next i
MsgBox "处理完成！", vbInformation
End Sub
' 从字符串中提取所有8位数字
Function Get8DigitNumbers(inputStr As String) As Collection
Dim regex As Object
Dim matches As Object
Dim match As Object
Dim result As New Collection
Set regex = CreateObject("VBScript.RegExp")
With regex
.Pattern = "\b\d{8}\b" ' 匹配8位数字
.Global = True ' 全局匹配
.IgnoreCase = True ' 不区分大小写
End With
Set matches = regex.Execute(inputStr)
For Each match In matches
result.Add match.Value
Next match
Set Get8DigitNumbers = result
End Function
' 检查两个集合是否有共同元素
Function HasCommonItem(col1 As Collection, col2 As Collection) As Boolean
Dim item1 As Variant
Dim item2 As Variant
For Each item1 In col1
For Each item2 In col2
If item1 = item2 Then
HasCommonItem = True
Exit Function
End If
Next item2
Next item1
HasCommonItem = False
End Function

进入原文