关于数据合并问题请教

zt19940416

各位大佬，我有一个表格，里边很多数据，需要将左侧这样的，根据包号和ID合并成右侧这样的，原则是按包号里边的ID号，来合并后边的省份和项目名，同一个ID下省份和项目名不能有重复的，大佬们看下附件，谢谢

duquancai

1. Sub main()
   
2.     Dim a, js As Object, j$, d As Object, b(), k, t, s
   
3.     a = Range("a2:d" & Cells(Rows.Count, 2).End(3).Row)
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     For i = 1 To UBound(a)
   
6.         If Len(a(i, 1)) * Len(a(i, 2)) Then d(a(i, 1) & "|" & a(i, 2)) = d(a(i, 1) & "|" & a(i, 2)) & "," & i
   
7.     Next
   
8.     k = d.keys: t = d.items: ReDim b(1 To UBound(k) + 1, 1 To UBound(a, 2))
   
9.     Set js = CreateObject("MSScriptControl.ScriptControl")
   
10.     js.Language = "JavaScript"
    
11.     For i = 0 To UBound(k)
    
12.         s = Split(k(i), "|"): r = Split(Mid(t(i), 2), ","): s1 = Empty: s2 = Empty
    
13.         For Each x In r
    
14.             s1 = s1 & "," & a(x, 3): s2 = s2 & "," & a(x, 4)
    
15.         Next
    
16.         s1 = Mid(s1, 2): s2 = Mid(s2, 2): b(i + 1, 1) = s(0): b(i + 1, 2) = s(1)
    
17.         j = "a='',b='',o={},q={};'" & s1 & "'.replace(/[^,]+/g,function(s){o[s]=1;});"
    
18.         j = j & "'" & s2 & "'.replace(/[^,]+/g,function(s){q[s]=1;});"
    
19.         j = j & "for(k in o)a?a+=';'+k:a=k;for(k in q)b?b+=';'+k:b=k;"
    
20.         b(i + 1, 3) = js.eval(j & "a;")
    
21.         b(i + 1, 4) = js.eval(j & "b;")
    
22.     Next
    
23.     Range("f2:j100").ClearContents
    
24.     Range("f2").Resize(i, UBound(a, 2)) = b
    
25. End Sub

复制代码

zt19940416

mikezhan 发表于 2018-7-29 13:08
Sub test()
Dim arr, brr, crr()
arr = Range("A2:D" & Cells(100000, 1).End(xlUp).Row)

非常感谢，还想请教下，如果我有多个包，通过设置字典的方式感觉有点麻烦，敢问还有什么其他办法吗？

jiminyanyan

mikezhan 发表于 2018-7-29 16:23
你是说跨工作簿吗？ 字典也没问题啊。完全可以。

特别是在 大数据时，那些什么函数什么的，全是扯蛋的 ...

大数据，字典+数组也会吃不消。