如何编辑VBA查找多表单元格数据是否唯一性？

dwqqh · 发表于 2014-9-23 23:45

su45 · 发表于 2014-9-24 00:04

估计没人会给你做，一是发错地方了，二是数据量太大，建议改用数据库吧！

wp8680 · 发表于 2014-9-24 08:25

问题不难，可以实现的。并且各分表可能为多个工作簿，也可能实现多工作簿汇总的。

wp8680 · 发表于 2014-9-24 09:36

Sub 查找()
Dim arr, ir&, k&, nam$$, shnam$$
Dim brr, ir1&, k1&, sh As Worksheet, B As Boolean, N%, nam1
Dim crr(), a&
With Worksheets("要查找的数据")
.Select
shnam = .Name
ir = .Range("c" & Cells.Rows.Count).End(xlUp).Row
arr = .Range("a2:e" & ir)
End With
For k = 1 To UBound(arr, 1)
nam = arr(k, 3)
a = a + 1
ReDim Preserve crr(1 To 7, 1 To a)
crr(1, a) = arr(k, 1)
crr(2, a) = arr(k, 2)
crr(3, a) = arr(k, 3)
crr(4, a) = arr(k, 4)
crr(5, a) = arr(k, 5)
crr(6, a) = shnam
crr(7, a) = "c" & k + 1
For Each sh In ThisWorkbook.Worksheets
If Left(sh.Name, 5) = "Sheet" Then
With sh
ir1 = .Range("c" & Cells.Rows.Count).End(xlUp).Row
brr = .Range("a2:e" & ir)
End With
For k1 = 1 To UBound(brr, 1)
nam1 = Split(brr(k1, 3), "、")
B = False
For N = 0 To UBound(nam1)
'是否需要加上重名限制
If InStr(nam, nam1(N)) > 0 Then B = True: Exit For
Next N
If B Then
a = a + 1
ReDim Preserve crr(1 To 7, 1 To a)
crr(1, a) = brr(k1, 1)
crr(2, a) = brr(k1, 2)
crr(3, a) = brr(k1, 3)
crr(4, a) = brr(k1, 4)
crr(5, a) = brr(k1, 5)
crr(6, a) = sh.Name
crr(7, a) = "c" & k1 + 1
End If
Next k1
End If
Next sh
Next k
Worksheets.Add after:=Worksheets(ThisWorkbook.Sheets.Count)
ActiveSheet.Name = "汇总" & ThisWorkbook.Sheets.Count
Columns("D:D").NumberFormatLocal = "@"
Range("A2").Resize(UBound(crr, 2), 7) = Application.WorksheetFunction.Transpose(crr)
End Sub

复制代码

dwqqh · 发表于 2014-9-24 19:50

wp8680 发表于 2014-9-24 09:36

已复制代码，未达到效果。

wp8680 · 发表于 2014-9-25 16:15

dwqqh 发表于 2014-9-24 19:50
已复制代码，未达到效果。

不可能达不到效果，我试了是行了。

现在本文中上传的文件附件中，有自杀代码，请在使用前关闭其他工作簿。

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