[已解决]表2里的数据在表1数据里有的，就保留下来，没有的就删除;表1里有的数据在表2中没有的

我不知道呀 · 发表于 2011-12-23 07:13

表2里的数据在表1数据里有的，就保留下来，没有的就删除;表1里有的数据在表2中没有的，添加到表2中去。该题用VLOOKUP做在数据量少时，比较快，但数据达到2万行以上时，对其操作就非常慢。请大家帮忙，谢谢！效果如下图

最佳答案

月排行榜 / 总排行榜

zjdh

2011-12-23 08:51

梳理数据.rar (25.05 KB, 下载次数: 57)

zjdh · 发表于 2011-12-23 08:51

梳理数据.rar (25.05 KB, 下载次数: 57)

windimi007 · 发表于 2011-12-23 09:00

{:3912:}我也来一个，哈哈！

Sub aa()
Dim d1 As Object, d2 As Object
Dim arr1, arr2
Dim arr(1 To 30000, 1 To 4)
Dim i&, j&
Application.ScreenUpdating = False
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
arr1 = Sheet1.Range("A1").CurrentRegion
arr2 = Sheet2.Range("A1").CurrentRegion
For i = 2 To UBound(arr1)
d1(arr1(i, 1)) = arr1(i, 2) & vbTab & arr1(i, 3)
Next i
For i = 2 To UBound(arr2)
If d1.exists(arr2(i, 2)) Then
j = j + 1
d2(arr2(i, 2)) = ""
arr(j, 1) = arr2(i, 1)
arr(j, 2) = arr2(i, 2)
arr(j, 3) = arr2(i, 3)
arr(j, 4) = arr2(i, 4)
End If
Next i
Erase arr2
Set d1 = Nothing
For i = 2 To UBound(arr1)
If Not d2.exists(arr1(i, 1)) Then
j = j + 1
arr(j, 2) = arr1(i, 1)
arr(j, 3) = arr1(i, 2)
arr(j, 4) = arr1(i, 3)
End If
Next i
Erase arr1
Set d2 = Nothing
Sheets.Add(, Sheets(Sheets.Count)).Name = "NEW"
Range("A1").Resize(, 4) = [{"月份","编号","学生","成绩"}]
Range("A2").Resize(UBound(arr), 4) = arr
Application.ScreenUpdating = True
End Sub

复制代码

我不知道呀 · 发表于 2011-12-23 20:52

zjdh 发表于 2011-12-23 08:51

字典刚刚接触一点点，我对您的代码的理解不知道对不对，请zjdh看下，谢谢！！

Sub test()
ARR = Range("A2:C" & Range("A65536").End(3).Row) '把表1的数据存入数组ARR
Set D = CreateObject("scripting.dictionary") '创建一个字典
For I = 1 To UBound(ARR)
      If ARR(I, 1) <> "" Then '如果表1中的编号不为空，那么把表1中的每列的数据连接起来赋值给CJ
         CJ = "|" & ARR(I, 1) & "|" & ARR(I, 2) & "|" & ARR(I, 3)

         '问题中要求：表1里有的数据在表2中没有的，添加到表2中去。以下代码就实现了把表1里的数据添加到字典，把表2中的数据在表1中存在的数据再次添加到字典
         If Not D.exists(ARR(I, 1)) Then '如果字典中不存在表1中的编号，那么在字典中添加关键字（即编号）和Item（即每列连接起来的数据CJ）
            D.Add ARR(I, 1), CJ '当I=1时在字典中存在的样式如：Key为X10001，Item为|X10001|A|100
         End If
      End If
Next
BRR = Sheets("表2").Range("A2:D" & Sheets("表2").Range("A65536").End(3).Row) '把表2的数据存入数组BRR
For I = 1 To UBound(BRR)
      If BRR(I, 2) <> "" Then '如果表2中的编号不空，那么将表2中的每列数据连接起来赋值给CJ
         CJ = BRR(I, 1) & "|" & BRR(I, 2) & "|" & BRR(I, 3) & "|" & BRR(I, 4)
         If D.exists(BRR(I, 2)) Then '此时的字典已是存入了表1数据的字典，如果字典中存在表2的编号。
            D(BRR(I, 2)) = CJ '那么就将表2的每列连接起来的数据赋给字典关键字为表2编号Item项。此项功能是把表2中的数据在表1中存在的数据，全部赋给字典
         End If
      End If
Next
S = D.ItemS '把字典的Item项的值全部赋给数组S
ReDim CRR(1 To UBound(S) + 1, 1 To 4) '重新定义一个CRR数组
For I = 0 To UBound(S)
      For J = 1 To 4
         CRR(I + 1, J) = Split(S(I), "|")(J - 1) '将原来每行连接起来的数据依次分出来，赋给数据CRR
      Next
Next
Sheets("表2").Range("A2:D" & Range("A65536").End(3).Row + 1).ClearContents '清空表2的数组
Sheets("表2").Range("A2").Resize(UBound(CRR), 4) = CRR '把数组CRR填充至表2
End Sub

zjdh · 发表于 2011-12-23 21:08

注释得很好，这一句再作点说明：
D(BRR(I, 2)) = CJ
是刷新字典相关Item项，因为这里的CJ包含月份。

我不知道呀 · 发表于 2011-12-23 21:15

zjdh 发表于 2011-12-23 21:08
注释得很好，这一句再作点说明：
D(BRR(I, 2)) = CJ
是刷新字典相关Item项，因为这里的CJ包含月份。

字典功能很强大，努力学习，谢谢您！

sxxn2010 · 发表于 2011-12-24 15:34

不错，呵呵学习一了，

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

[已解决]表2里的数据在表1数据里有的，就保留下来，没有的就删除;表1里有的数据在表2中没有的

点评