vba查询excel工作表内有没有重复的单元格，只能找出第一对重复的

likeyouli · 发表于昨天 20:56

本帖最后由 likeyouli 于 2026-3-22 18:47 编辑

别再用ai答复我了，我这是分享，不是求助，ai回答的我都不满意，我写的每个代码我都理解其意义。
vba就是要活学活用，我为啥分享这个？因为这个是我的基础分享，这绝不是为了单纯查询重复，而是为了代码后边的部分（因具体需求不同不再分享）。一开始觉得这个代码很简单，无非数组和字典，但真写起来，竟然用了两个正则，用了union，用了find、findnext等，甚至我也不知道inputbox输入的内容为字符串自带引号，比如输入a1传递给变量quyu，可以用range(quyu)，因为这就代表了range("a1")，而不需要输入"a1"；输入b2:c390就代表range("b2:c390")，总之，写这么简单的代码竟然费了我好几遍精力，所以才想起来分享。

Sub 查询工作表内单元格有没有重复值()
Dim d As New Dictionary, dizhi As Range, r As New RegExp, dizhi1 As Range
'两次使用正则表达式判定输入的格式是否正确
'Set r = CreateObject("VBScript.RegExp")
kaishi:
quyu = InputBox("请输入活动工作表的一个单元格（如a1，用currentregion）或输入一个区域（b2:c390）：", "请输入", "b2:c101")
Stop
r.Global = True
r.Pattern = "^[a-zA-Z]\d+$"
If r.Test(quyu) Then linshi = 3 Else linshi = 0
r.Pattern = "^[a-zA-Z]\d+:[a-zA-Z]\d+$"
If Not (r.Test(quyu)) And linshi = 0 Then MsgBox "输入格式错误，请重新输入": GoTo kaishi
If r.Test(quyu) Then
Range(quyu).Select
MsgBox "请查看选中的区域"
arr = Range(quyu)
For hang = LBound(arr) To UBound(arr)
      For lie = LBound(arr, 2) To UBound(arr, 2)
         If d.Exists(arr(hang, lie)) And arr(hang, lie) <> "" Then
         Set dizhi = Range(quyu).Find(arr(hang, lie))
         Set dizhi1 = Range(quyu).FindNext(dizhi)
            MsgBox "存在重复单元格，查询到的第一个重复单元格内容为""" & arr(hang, lie) & _
            """；地址为" & dizhi.Address(0, 0) & "和" & dizhi1.Address(0, 0): Union(dizhi, dizhi1).Select: Exit Sub
         Else
            d(arr(hang, lie)) = ""
         End If
      Next lie
Next hang
' Range(quyu).Interior.Pattern = xlPatternNone
Else
Range(quyu).CurrentRegion.Select
MsgBox "请查看选中的颜色区域"
arr = Range(quyu).CurrentRegion
   For hang = LBound(arr) To UBound(arr)
      For lie = LBound(arr, 2) To UBound(arr, 2)
         If d.Exists(arr(hang, lie)) And arr(hang, lie) <> "" Then
         Set dizhi = Range(quyu).CurrentRegion.Find(arr(hang, lie))
         Set dizhi1 = Range(quyu).CurrentRegion.FindNext(dizhi)
            MsgBox "存在重复单元格，查询到的第一个重复单元格内容为""" & arr(hang, lie) & _
            """；地址为" & dizhi.Address(0, 0) & "和" & dizhi1.Address(0, 0): Union(dizhi, dizhi1).Select: Exit Sub
         Else
            d(arr(hang, lie)) = ""
         End If
      Next lie
Next hang
' Range(quyu).CurrentRegion.Interior.Pattern = xlPatternNone
End If
MsgBox "恭喜，未发现重复单元格，代码结束！！"
End Sub

邪恶海盗 · 发表于昨天 21:14

没看内容，我说一下逻辑：
1.分别返回有数据的最左最右列、最上最下行
2.循环挨个从左上单元格开始往下往右直到右下角单元格查找
3.将2获取到的值再与循环挨个从左上到右下角单元格比对
完毕...

1e3e · 发表于昨天 21:14

谢谢，vba高手啊

l3429900 · 发表于昨天 21:30

ai可以编写，还可以修改

likeyouli · 发表于昨天 21:33

本帖最后由 likeyouli 于 2026-3-21 21:37 编辑

字典不会引用的
可以加上 set d = createobject("scripting.dictionary") 否则报错；
同理正则不会引用的，直接将Set r = CreateObject("VBScript.RegExp") 前边的 ' 去掉即可（即解除注释）

newswan · 发表于昨天 21:37

excel 能直接显示重复单元格

holley2008 · 发表于昨天 21:40

我来帮着用AI改（其实最好有个现成的例子，这样出结果快）：

Sub 查找所有重复值()
Dim d As Object, arr() As String
Dim rng As Range, cell As Range
Dim quyu As String, i As Long
Dim hasDuplicates As Boolean
'创建字典对象
Set d = CreateObject("Scripting.Dictionary")
'获取用户输入的区域
On Error Resume Next
Set rng = Application.InputBox( _
"请选择要检查的区域：", _
"选择区域", _
Selection.Address, _
Type:=8)
On Error GoTo 0
If rng Is Nothing Then Exit Sub '用户取消
'检查重复值
For Each cell In rng
If Len(Trim(cell.Value)) > 0 Then
If d.Exists(cell.Value) Then
d(cell.Value) = d(cell.Value) & ", " & cell.Address(0, 0)
hasDuplicates = True
Else
d(cell.Value) = cell.Address(0, 0)
End If
End If
Next cell
If hasDuplicates Then
'显示所有重复值
ReDim arr(1 To d.Count, 1 To 3)
i = 0
For Each cell In rng
If Len(Trim(cell.Value)) > 0 Then
Dim addresses As String
addresses = d(cell.Value)
'如果地址中包含逗号，说明有重复
If InStr(addresses, ",") > 0 Then
i = i + 1
arr(i, 1) = cell.Value
arr(i, 2) = addresses
arr(i, 3) = Len(Split(addresses, ",")) '重复次数
'高亮显示重复单元格
cell.Interior.Color = RGB(255, 255, 0)
End If
End If
Next cell
'在工作表中显示结果
Dim ws As Worksheet
Set ws = Worksheets.Add
ws.Name = "重复值报告"
With ws
.Range("A1:C1") = Array("重复内容", "所在位置", "重复次数")
.Range("A2").Resize(i, 3) = arr
.Columns.AutoFit
.Rows(1).Font.Bold = True
End With
MsgBox "共发现 " & i & " 个重复值，已在新建的工作表中显示。"
Else
MsgBox "恭喜！未发现重复值。", vbInformation
End If
'清除高亮
rng.Interior.ColorIndex = xlNone
End Sub

复制代码

a66 · 发表于昨天 21:43

本帖最后由 a66 于 2026-3-22 08:11 编辑

Sub 查询工作表内单元格有没有重复值()
Dim d As Object
Dim quyu As String
Dim r As Object
Dim arr As Variant
Dim hang As Long, lie As Long
Dim firstAddr As String, secondAddr As String
Dim targetRange As Range
' 创建字典和正则对象
Set d = CreateObject("Scripting.Dictionary")
Set r = CreateObject("VBScript.RegExp")
' 设置字典比较模式为文本不区分大小写（可选）
d.CompareMode = vbTextCompare
input_retry:
quyu = InputBox("请输入活动工作表的一个单元格（如A1，将使用CurrentRegion）或一个区域（如B2:C390）：", "输入区域", "B2:C101")
' 用户取消
If quyu = "" Then Exit Sub
' 正则验证输入格式
r.Global = True
r.IgnoreCase = True
' 情况1：单个单元格（如 A1）
r.Pattern = "^[a-z]+\d+$"
If r.Test(quyu) Then
Set targetRange = Range(quyu).CurrentRegion
MsgBox "将检查区域：" & targetRange.Address, vbInformation
Else
' 情况2：区域（如 B2:D100）
r.Pattern = "^[a-z]+\d+:[a-z]+\d+$"
If r.Test(quyu) Then
Set targetRange = Range(quyu)
MsgBox "将检查区域：" & targetRange.Address, vbInformation
Else
MsgBox "输入格式错误！请使用类似 A1 或 B2:C100 的格式。", vbExclamation
GoTo input_retry
End If
End If
' 将区域值读入数组（提升效率）
If targetRange.Cells.Count = 1 Then
ReDim arr(1 To 1, 1 To 1)
arr(1, 1) = targetRange.Value
Else
arr = targetRange.Value
End If
' 遍历数组
For hang = LBound(arr, 1) To UBound(arr, 1)
For lie = LBound(arr, 2) To UBound(arr, 2)
Dim cellValue As Variant
cellValue = arr(hang, lie)
' 跳过空单元格
If Not IsEmpty(cellValue) And cellValue <> "" Then
' 如果字典中已存在该值 → 找到第一对重复！
If d.Exists(cellValue) Then
firstAddr = d(cellValue) ' 首次出现的地址
secondAddr = targetRange.Cells(hang, lie).Address(0, 0) ' 当前地址
' 报告结果
MsgBox "存在重复单元格！" & vbCrLf & _
"内容：""" & cellValue & """" & vbCrLf & _
"位置：" & firstAddr & " 和 " & secondAddr, vbCritical
' 选中两个单元格
Union(Range(firstAddr), Range(secondAddr)).Select
' 可选：高亮显示（取消注释下一行）
' Union(Range(firstAddr), Range(secondAddr)).Interior.Color = RGB(255, 255, 0)
Exit Sub ' 仅找第一对，立即退出
Else
' 记录首次出现的地址
d(cellValue) = targetRange.Cells(hang, lie).Address(0, 0)
End If
End If
Next lie
Next hang
' 若执行到此处，说明无重复
MsgBox "恭喜！未发现重复的非空单元格。", vbInformation
End Sub

复制代码

likeyouli · 发表于昨天 21:53

newswan 发表于 2026-3-21 21:37
excel 能直接显示重复单元格

是的，条件格式里就能设置，，但vba更灵活，我想让代码怎么跑就怎么跑；
另外，查重复不是目的，这只是我代码一部分。我想用find查询，因为find只能查询到第一个待搜索内容，然后表格之间相加，然后自动更新表格数据....

cutebe · 发表于 13 小时前

第一个查找FindNext区域与Find区域有变化，后面也没有判断地址是否与首地址相同。

Set dizhi = Range(quyu).Find(arr(hang, lie))
Set dizhi1 = Range(quyu).CurrentRegion.FindNext(dizhi)

第二个查找区域相同，但也没有判断地址。

Set dizhi = Range(quyu).CurrentRegion.Find(arr(hang, lie))
Set dizhi1 = Range(quyu).CurrentRegion.FindNext(dizhi)

'示例
Set 查找区域 = 工作表.UsedRange
Set 查找单元格=工作表.Cells(1,3)
查找内容=查找单元格.Value
Set 内容单元格 = 查找区域.Find(查找内容)
内容单元格地址 = 内容单元格.Address
Set 找下一个单元格 = 查找区域.FindNext(内容单元格)
If Not 找下一个单元格 Is Nothing And 找下一个单元格.Address <> 内容单元格地址
找到第一个单元格地址=找下一个单元格.Address
End If

复制代码

newswan · 发表于 10 小时前

likeyouli 发表于 2026-3-21 21:53
是的，条件格式里就能设置，，但vba更灵活，我想让代码怎么跑就怎么跑；
另外，查重复不是目的，这只是 ...

很久没用 vba , 已经忘记了
刚才问 ai

Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
新增 dict.Add "A001", "苹果" 向字典添加一个键值对
赋值/修改 dict("A001") = "香蕉" 如果键存在则修改，不存在则新增
判断是否存在 if dict.Exists("A001") Then 检查某个键是否已经在字典里
读取值 msgbox dict("A001") 通过键获取对应的数值
删除单个 dict.Remove "A001" 删除特定的键值对
清空 dict.RemoveAll 一键清空字典

复制代码

用字典判断有没有重复

newswan · 发表于 10 小时前

ai 写了一个样本

Sub RecordDuplicatesAndAddresses()
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim i As Long
Dim lastRow As Long
Dim key As String
Dim addr As String
' 获取A列最后一行
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
' 1. 遍历数据并记录
For i = 2 To lastRow
key = Cells(i, 1).Value
addr = Cells(i, 1).Address(False, False) ' 获取如 "A2" 格式的地址
If dict.Exists(key) Then
' 如果已经存在，就在原有地址后面加上逗号和新地址
dict(key) = dict(key) & ", " & addr
Else
' 如果是第一次出现，直接记录地址
dict(key) = addr
End If
Next i
' 2. 将结果输出到 D 列和 E 列
Dim k As Variant
Dim r As Long: r = 2
' 清理输出区域
Range("D2:E" & Rows.Count).ClearContents
For Each k In dict.Keys
' 只有当地址中包含逗号时，说明出现了至少两次（即重复）
If InStr(dict(k), ",") > 0 Then
Cells(r, 4).Value = k ' 重复的值
Cells(r, 5).Value = dict(k) ' 所有的单元格地址
r = r + 1
End If
Next k
MsgBox "完成！已在 D:E 列记录重复项及其位置。"
End Sub

复制代码

likeyouli · 发表于 5 小时前

本帖最后由 likeyouli 于 2026-3-22 19:05 编辑

cutebe 发表于 2026-3-22 10:04
第一个查找FindNext区域与Find区域有变化，后面也没有判断地址是否与首地址相同。

感谢提醒，“第一个查找FindNext区域与Find区域有变化” ，已经改正。
后边这句“没有判断地址是否与首地址相同” 我没有理解什么意思... 又看了下你发的代码，我既然确定是重复了（用字典判断的），所以findnext查找的单元格地址肯定与第一个查找的地址不同，所以根本不需要判断。你所谓的需要判断，是指只能查找出一个（即没有重复的），才需要判断一下。

我费了很大劲、连用两个正则表达式，就是为了选择工作表的哪个区域作为查询有没有重复的区域，很多ai用的currentregion，Excel自带的查重复是用的selection，这两个我都不满意。

liwangzhe · 发表于 5 小时前

学习一下

		自动登录	找回密码
密码			注册

vba查询excel工作表内有没有重复的单元格，只能找出第一对重复的

点评

点评

点评