[已解决]二列核对，求相同数据的VBA

wuliao_tao

我有几万条信息要核对，如A列与B列核对，如果姓名一致，就在C列列出核对出结果，求VBA
核对结果.rar (1.81 KB, 下载次数: 6)

2015-10-13 12:34 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

air05

2015-10-13 13:06

1. Sub 核对()
   
2.     Dim d As Object, arr, brr(), i&, x&
   
3.     arr = [a1].CurrentRegion
   
4.     x = UBound(arr)
   
5.     ReDim brr(1 To x, 1 To 1)
   
6.     Set d = CreateObject("Scripting.Dictionary")
   
7.     For i = 2 To x
   
8.         d(arr(i, 1)) = ""
   
9.     Next
   
10.     For i = 2 To x
    
11.         If arr(i, 2) = "" Then Exit For
    
12.         If d.exists(arr(i, 2)) Then brr(i, 1) = "相符" Else brr(i, 1) = "无"
    
13.     Next
    
14.     brr(1, 1) = "核对结果"
    
15.     Range("c2:c" & x).Clear
    
16.     Range("c1").Resize(x) = brr
    
17. End Sub

复制代码

核对结果.rar (12.46 KB, 下载次数: 15)

2015-10-13 13:06 上传

点击文件名下载附件

跳转到最佳答案楼层

sry660

1. Sub 核对数据()
   
2. Application.ScreenUpdating = False
   
3. [c2:c65536].Clear
   
4. Dim j&, jRow&
   
5. jRow = Cells(Rows.Count, 2).End(xlUp).Row
   
6.     For j = 2 To jRow
   
7.         If Application.CountIf([a:a], Cells(j, 2)) > 0 Then
   
8.             Cells(j, 3) = "相符"
   
9.         Else
   
10.             Cells(j, 3) = "无"
    
11.         End If
    
12.     Next
    
13. Application.ScreenUpdating = True
    
14. MsgBox "核对结束！"
    
15. End Sub

复制代码

baksy

C2公式，下拉；
=IF(COUNTIF(A:A,B2),"相符","无")

wuliao_tao

sry660 发表于 2015-10-13 12:47

你误解我的意思了，AB二列姓名排列是不一样的，找出他们相同的姓名。

air05

1. Sub 核对()
   
2.     Dim d As Object, arr, brr(), i&, x&
   
3.     arr = [a1].CurrentRegion
   
4.     x = UBound(arr)
   
5.     ReDim brr(1 To x, 1 To 1)
   
6.     Set d = CreateObject("Scripting.Dictionary")
   
7.     For i = 2 To x
   
8.         d(arr(i, 1)) = ""
   
9.     Next
   
10.     For i = 2 To x
    
11.         If arr(i, 2) = "" Then Exit For
    
12.         If d.exists(arr(i, 2)) Then brr(i, 1) = "相符" Else brr(i, 1) = "无"
    
13.     Next
    
14.     brr(1, 1) = "核对结果"
    
15.     Range("c2:c" & x).Clear
    
16.     Range("c1").Resize(x) = brr
    
17. End Sub

复制代码

核对结果.rar (12.46 KB, 下载次数: 15)

2015-10-13 13:06 上传

点击文件名下载附件