如何用VBA数组+字典，将二个工作表的相同内容的对齐，放在同一行？

marchwen01

VBA之恋 发表于 2017-6-18 22:12
哦，你好，帮我看，能不能改后，能得到我想要的

面对这样大数据，毫无办法。两个表一共二十几万行数据，放到Access也比较不了。

只能用小办法，面对的只有小数据了。

1. Option Explicit
   
2. 
   
3. Sub FunMode()
   
4.     Dim arr1, arr2, iCol1, iCol2, tmp()
   
5.     Dim lRow1 As Long, lRow2 As Long, lRowTmp As Long
   
6.     Dim i As Integer, maxCol1 As Integer, maxCol2 As Integer
   
7.     Dim d As Object, dicKey
   
8.    
   
9.     iCol1 = Array(1, 2, 3, 4, 7, 8)
   
10.     iCol2 = Array(1, 2, 3, 4, 5, 9)
    
11.     arr1 = Worksheets("比较表一").Range("A1").CurrentRegion
    
12.     arr2 = Worksheets("比较表二").Range("A1").CurrentRegion
    
13.    
    
14.     maxCol1 = UBound(arr1, 2)
    
15.     maxCol2 = UBound(arr2, 2)
    
16.     ReDim tmp(1 To UBound(arr1) + UBound(arr2), 1 To maxCol1 + maxCol2)
    
17.    
    
18.     Set d = CreateObject("Scripting.Dictionary")
    
19.     For lRow2 = 2 To UBound(arr2)
    
20.         d(lRow2) = ""
    
21.     Next
    
22.    
    
23.     For i = 1 To maxCol1
    
24.         tmp(1, i) = arr1(1, i)
    
25.     Next
    
26.     For i = i To UBound(tmp, 2)
    
27.         tmp(1, i) = arr2(1, i - maxCol1)
    
28.     Next
    
29.    
    
30.     lRowTmp = 1
    
31.     For lRow1 = 2 To UBound(arr1)
    
32.         For lRow2 = 2 To UBound(arr2)
    
33.             For i = 0 To UBound(iCol1)
    
34.                 If arr1(lRow1, iCol1(i)) <> arr2(lRow2, iCol2(i)) Then Exit For
    
35.             Next
    
36.             If i > UBound(iCol1) Then
    
37.                 lRowTmp = lRowTmp + 1
    
38.                 For i = 1 To maxCol1
    
39.                     tmp(lRowTmp, i) = arr1(lRow1, i)
    
40.                 Next
    
41.                 For i = i To UBound(tmp, 2)
    
42.                     tmp(lRowTmp, i) = arr2(lRow2, i - maxCol1)
    
43.                 Next
    
44.                 d.Remove lRow2
    
45.                 Exit For
    
46.             End If
    
47.         Next
    
48.         If lRow2 > UBound(arr2) Then
    
49.             lRowTmp = lRowTmp + 1
    
50.             For i = 1 To maxCol1
    
51.                 tmp(lRowTmp, i) = arr1(lRow1, i)
    
52.             Next
    
53.         End If
    
54.     Next
    
55.    
    
56.     For Each dicKey In d.keys
    
57.         lRowTmp = lRowTmp + 1
    
58.         For i = maxCol1 + 1 To UBound(tmp, 2)
    
59.             tmp(lRowTmp, i) = arr2(dicKey, i - maxCol1)
    
60.         Next
    
61.     Next
    
62.    
    
63.     Worksheets("代码运行落点").Range("A1").Resize(lRowTmp, UBound(tmp, 2)) = tmp
    
64. End Sub
    
65. 
    
66. 
    
67. 
    

复制代码

zax010

VBA之恋 发表于 2017-6-18 21:15
你好，重复是因为是复制示例中的上面的数据，实际应用时，是不会有这么大量的重复数据。即是有，也无关紧 ...

输出数据量大，就不能循环填入单元格了。

可用数组代替单元格，循环填入后一次输出到工作表。

VBA之恋

marchwen01 发表于 2017-6-18 23:39
面对这样大数据，毫无办法。两个表一共二十几万行数据，放到Access也比较不了。

只能用小办法，面对的 ...

你好，代码运行到d.Remove lRow2，跳出提示、：应用程序定义或对象应用错误

marchwen01

VBA之恋 发表于 2017-6-19 22:29
你好，代码运行到d.Remove lRow2，跳出提示、：应用程序定义或对象应用错误

改一下

d.Remove lRow2  改为

if d.exists(lrow2) then d.remove lrow2


大数据还是不行。

VBA之恋

marchwen01 发表于 2017-6-19 22:49
改一下

d.Remove lRow2  改为

你好，如果对速度没有要求呢，半小时，一小时的，只能结果是正确的，能有效的，也行。这情况下，能达到目的吗？

excelvlookup

不管代码如何改，算法没有根本突破，皆徒劳。

VBA之恋

excelvlookup 发表于 2017-6-20 17:15
不管代码如何改，算法没有根本突破，皆徒劳。

哦，可惜了，谢谢您的回复。

yaozong

结合排序，仅供参考。   170621-如何让相同数据自动对齐.rar (22.1 KB, 下载次数: 40)

2017-6-22 10:03 上传

点击文件名下载附件

elon23

学习了，马下来，谢谢

yaozong

在28楼附件的基础上，作了更改，运行速度要快点。

170623-如何让相同数据自动对齐.rar (25.66 KB, 下载次数: 45)

2017-6-23 10:19 上传

点击文件名下载附件