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

VBA之恋

zax010 发表于 2017-6-18 13:26
又是审核！

1、如果数据上百w行，这个代码无能为力，仅给予参考；

你好，不能上百万行，那么几十万行，这代码有效吗？

VBA之恋

zax010 发表于 2017-6-18 13:21
Sub zz()
    Dim d(1 To 3) As New Dictionary, ar, br
    ar = Sheet1.Range("A1").CurrentRegion

你好，测试了二十几万行，提示类型不匹配，请问一下，能解决吗？是变量原因吗？还是VBA的局限？附件约十万行。


如何让相同数据自动对齐.rar (1.92 MB, 下载次数: 27)

2017-6-18 19:32 上传

点击文件名下载附件

zax010

1、数组超过65535行，不能用 Index 函数，数据须循环填入单元格。

2、两表中数据全是重复的，不知要何种输出，重复值也输出？若是，放弃这个吧。

VBA之恋

zax010 发表于 2017-6-18 20:44
1、数组超过65535行，不能用 Index 函数，数据须循环填入单元格。

2、两表中数据全是重复的，不知要何种 ...

你好，重复是因为是复制示例中的上面的数据，实际应用时，是不会有这么大量的重复数据。即是有，也无关紧要，重复的数据，相对应，对方有重复的数据一一对齐。在得到结果的情况下，可读入数组，循环填入单元格。

jjmysjg

看看完整的答案

marchwen01

VBA之恋 发表于 2017-6-18 19:10
你好，核算项目和供货单位没有放进去，且语句中，数量重复了二次，我想将其中改为核算项目和供货单位，不 ...

怎么会没有这两个字段？ 我在 SQL 语句中 用的 * ，代表所有字段。

在你的附件里头就是有两个数量的。

VBA之恋

marchwen01 发表于 2017-6-18 21:38
怎么会没有这两个字段？ 我在 SQL 语句中 用的 * ，代表所有字段。

在你的附件里头就是有两个数量的。

你好，图中的第17行的十二与三对应了

marchwen01

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

大量的数据，不要考虑循环填入单元格了，效率降得很厉害的。
取数组的某一行或者某一列，真不要用 工作表的 Index 函数，虽然语句是少了，但是效率比循环差太多了。

AFree123

学习、见识了，谢谢

VBA之恋

marchwen01 发表于 2017-6-18 21:45
大量的数据，不要考虑循环填入单元格了，效率降得很厉害的。
取数组的某一行或者某一列，真不要用 工作 ...

哦，你好，帮我看，能不能改后，能得到我想要的

1. Sub text()
   
2. Dim ar1, ar2, di1 As Object, di2 As Object
   
3. Dim i, j, k, a, b, c, ar
   
4. Dim m, n, arr()
   
5. With Sheets("代码没有执行前")
   
6.     ar1 = .Range("a1").Resize(.Cells(.Rows.Count, 1).End(3).Row, 7)
   
7.     ar2 = .Range("h1").Resize(.Cells(.Rows.Count, 8).End(3).Row, 5)
   
8. End With
   
9. Set di1 = CreateObject("scripting.dictionary")
   
10. Set di2 = CreateObject("scripting.dictionary")
    
11. For i = 2 To UBound(ar1)
    
12.     If ar1(i, 1) <> "" Then
    
13.         di1(ar1(i, 1)) = di1(ar1(i, 1)) & vbTab & i
    
14.         di2(ar1(i, 1)) = ""
    
15.     End If
    
16. Next
    
17. For i = 2 To UBound(ar2)
    
18.     If ar2(i, 1) <> "" Then
    
19.         If Not di1.exists(ar2(i, 1)) Then di1.Add ar2(i, 1), ""
    
20.         di2(ar2(i, 1)) = di2(ar2(i, 1)) & vbTab & i
    
21.     End If
    
22. Next
    
23. ar = di1.keys
    
24. ReDim arr(1 To 12, 1 To 1)
    
25. For j = 1 To UBound(ar1, 2)
    
26.     arr(j, 1) = ar1(1, j)
    
27. Next
    
28. For j = 1 To UBound(ar2, 2)
    
29.     arr(j + UBound(ar1, 2), 1) = ar2(1, j)
    
30. Next
    
31. For j = 0 To UBound(ar)
    
32.     b = UBound(arr, 2)
    
33.     m = Split(di1(ar(j)), vbTab): n = Split(di2(ar(j)), vbTab)
    
34.     a = IIf(UBound(m) >= UBound(n), UBound(m), UBound(n))
    
35.     c = b + a
    
36.     ReDim Preserve arr(1 To 12, 1 To c)
    
37.     If UBound(m) > 0 Then
    
38.         For i = 1 To UBound(m)
    
39.             For k = 1 To UBound(ar1, 2)
    
40.                 arr(k, b + i) = ar1(m(i), k)
    
41.             Next
    
42.         Next
    
43.     End If
    
44.     If UBound(n) > 0 Then
    
45.         For i = 1 To UBound(n)
    
46.             For k = 1 To UBound(ar2, 2)
    
47.                 arr(k + UBound(ar1, 2), b + i) = ar2(n(i), k)
    
48.             Next
    
49.         Next
    
50.     End If
    
51. Next
    
52. With Sheets("代码执行后的结果")
    
53.     .Range("a1").Resize(.Rows.Count, 12).Clear
    
54.     .Columns("b:b").NumberFormatLocal = "@"
    
55.     .Columns("i:i").NumberFormatLocal = "@"
    
56.     .Columns("c:c").NumberFormatLocal = "@"
    
57.     .Range("a1").Resize(UBound(arr, 2), 12) = WorksheetFunction.Transpose(arr)
    
58. End With
    
59. Set di1 = Nothing: Set di2 = Nothing: Erase ar1, ar2, ar, m, n, arr
    
60. End Sub
    

复制代码