用VBA进行数据对应查找

henrysu

  大神们帮忙看看下面的效果用VBA可不可以解决：

       1. 第一张表是原始数据，分为两组：A列至E列为一组，F列至J列为一组；同一组数据内有可能有相同的合同编号，但两组数据中每个同行的“合同编号+序号”在各自组内均唯一。

       2. 需要找出左边一组数据中是否有同行的“合同编号+序号”在右边一组数据中没有同行出现过，如果有的话需将这些“合同编号+序号”以及他们对应的三项费用列到“左有右无”表格。

       3. 需要找出右边一组数据中是否有同行的“合同编号+序号”在左边一组数据中没有同行出现过，如果有的话需将这些“合同编号+序号”以及他们对应的三项费用列到“右有左无”表格。

       4. 将在左右两组数据中均同行出现过的“合同编号+序号”以及他们分别在两组数据中对应的三项费用列到“左右都有”表格，“原始数据”表格中A列至E列的数据在“左右都有”表格中依然在A列至E列；“原始数据”表格中F列至J列的数据在“左右都有”表格中依然在F列至J列。

附件中只有第一张表是原始数据，后面的几张表都是希望可以达到的效果。之前试着用COUNTIF和VLOOKUP函数做过，但实际情况中每组数据大概有10万条，用这两个函数的话电脑计算速度非常慢，有时还会死机，所以想问下各位大神用VBA可不可以解决。


样本.rar (10.96 KB, 下载次数: 57)

2018-8-20 14:26 上传

点击文件名下载附件
样本

zhangzhang

详见附件。。。。。。。。。。

henrysu

zhangzhang 发表于 2018-8-20 15:32
详见附件。。。。。。。。。。

谢谢大神！我又把左边一组的数据复制了两行到右边（两组数据量不相等），点击按钮以后发现这两行数据还是出现在了“左有右无”表格中，请问针对两组数据数据量不相等的情况代码哪里可以优化吗？ 样本2.rar (22.26 KB, 下载次数: 47)

2018-8-20 16:21 上传

点击文件名下载附件
样本2

liujialin0o0

写的不好,清测试,可行的话给个鲜花

1. Sub tt()
   
2. Application.ScreenUpdating = False
   
3. 
   
4. a1 = Cells(Rows.Count, 1).End(3).Row
   
5. a2 = Cells(Rows.Count, 6).End(3).Row
   
6. 
   
7. ReDim m(a1 - 2)
   
8. ReDim n(a2 - 2)
   
9. Set arr1 = Range(Cells(2, 1), Cells(a1, 2))
   
10. Set arr2 = Range(Cells(2, 6), Cells(a2, 7))
    
11. 
    
12. For aa1 = 2 To a1
    
13.     m(aa1 - 2) = Cells(aa1, 1) & Cells(aa1, 2)
    
14. Next
    
15. 
    
16. For aa2 = 2 To a2
    
17.     n(aa2 - 2) = Cells(aa2, 6) & Cells(aa2, 7)
    
18. Next
    
19. 
    
20. Cells(2, 13).Resize(a1 - 1, 1) = Application.Transpose(m)
    
21. Cells(2, 14).Resize(a2 - 1, 1) = Application.Transpose(n)
    
22. 
    
23. '----------------------------sheet2-------------------------------
    
24. 
    
25. Dim b(100000)
    
26. For Each mm In m
    
27.     j = j + 1
    
28.     If Columns(14).Find(mm) Is Nothing Then
    
29.         b(i) = j + 1
    
30.         Cells(b(i), 1).Resize(1, 5).Copy
    
31.         Sheets(2).Activate
    
32.         Cells(Rows.Count, 1).End(3).Offset(1, 0).Select
    
33.         Sheets(2).Paste
    
34.         i = i + 1
    
35.         Sheets(1).Activate
    
36.     End If
    
37. 
    
38. Next
    
39. 
    
40. '----------------------------sheet3-------------------------------
    
41. 
    
42. i = 0
    
43. j = 0
    
44. 
    
45. Dim c(100000)
    
46. For Each nn In n
    
47.     j = j + 1
    
48.     If Columns(13).Find(nn) Is Nothing Then
    
49.         c(i) = j + 1
    
50.         Cells(c(i), 6).Resize(1, 5).Copy
    
51.         Sheets(3).Activate
    
52.         Cells(Rows.Count, 1).End(3).Offset(1, 0).Select
    
53.         Sheets(3).Paste
    
54.         i = i + 1
    
55.         Sheets(1).Activate
    
56.     End If
    
57. Next
    
58. 
    
59. '----------------------------sheet4-------------------------------
    
60. i = 0
    
61. j = 0
    
62. 
    
63. Dim d1(100000)
    
64. For Each mm In m
    
65.     j = j + 1
    
66.     If Not Columns(14).Find(mm) Is Nothing Then
    
67.         d1(i) = j + 1
    
68.         Cells(d1(i), 1).Resize(1, 5).Copy
    
69.         Sheets(4).Activate
    
70.         Cells(Rows.Count, 1).End(3).Offset(1, 0).Select
    
71.         Sheets(4).Paste
    
72.         i = i + 1
    
73.         Sheets(1).Activate
    
74.     End If
    
75. Next
    
76. 
    
77. i = 0
    
78. j = 0
    
79. 
    
80. Dim d2(100000)
    
81. For Each nn In n
    
82.     j = j + 1
    
83.     If Not Columns(13).Find(nn) Is Nothing Then
    
84.         d2(i) = j + 1
    
85.         Cells(d2(i), 6).Resize(1, 5).Copy
    
86.         Sheets(4).Activate
    
87.         Cells(Rows.Count, 6).End(3).Offset(1, 0).Select
    
88.         Sheets(4).Paste
    
89.         i = i + 1
    
90.         Sheets(1).Activate
    
91.     End If
    
92. Next
    
93. 
    
94. '----------------------------End-------------------------------
    
95. 
    
96. Sheets(1).Columns("M:N").ClearContents
    
97. Set arr1 = Nothing
    
98. Set arr2 = Nothing
    
99. Erase m, n, b, c, d1, d2
    
100. MsgBox "End!"
     
101. Application.ScreenUpdating = True
     
102. 
     
103. End Sub
     

复制代码

henrysu

mikezhan 发表于 2018-8-20 16:45
Sub test()
Dim arr, brr, LR(), L(), R(), shLR1(), shLR2(), shL(), shR()

谢谢大神了

henrysu

liujialin0o0 发表于 2018-8-20 16:44
写的不好,清测试,可行的话给个鲜花

谢谢大神。

liujialin0o0

mikezhan 发表于 2018-8-20 21:04
对单元格的直接读写是败笔

还在学习之中,有什么更好的更快速的方法情指教,谢谢

liujialin0o0

mikezhan 发表于 2018-8-20 21:04
对单元格的直接读写是败笔

高手,字典还不是太懂,学习了