[已解决]类比提取数据的问题

晓敏

附件 类比提取数据附件.rar (134.48 KB, 下载次数: 10)

2014-12-13 10:30 上传

点击文件名下载附件
谢谢！

最佳答案

月排行榜 / 总排行榜

dsmch

2014-12-13 18:29

………………

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr, d, d2, i&, s&
   
3. Dim c As Range, c2 As Range, j%, k%
   
4. Sheet3.Activate
   
5. Set d = CreateObject("scripting.dictionary")
   
6. Set d2 = CreateObject("scripting.dictionary")
   
7. arr = Sheet1.Range("a1").CurrentRegion
   
8. brr = Sheet2.Range("a1").CurrentRegion
   
9. ReDim crr(1 To 60000, 1 To UBound(arr, 2))
   
10. For i = 1 To UBound(arr)
    
11.     If Not d.exists(arr(i, 1)) Then
    
12.         d(arr(i, 1)) = i
    
13.     Else
    
14.         d(arr(i, 1)) = d(arr(i, 1)) & "," & i
    
15.     End If
    
16. Next
    
17. For i = 1 To UBound(brr)
    
18.     If Not d2.exists(brr(i, 1)) Then
    
19.         d2(brr(i, 1)) = i
    
20.     Else
    
21.         d2(brr(i, 1)) = d2(brr(i, 1)) & "," & i
    
22.     End If
    
23. Next
    
24. a = d.keys: b = d.items
    
25. For i = 0 To d.Count - 1
    
26.     If d2.exists(a(i)) Then
    
27.         x = Split(b(i), ",")
    
28.         For j = 0 To UBound(x)
    
29.             s = s + 1
    
30.             If c Is Nothing Then
    
31.                 Set c = Cells(s, 1)
    
32.             Else
    
33.                 Set c = Union(c, Cells(s, 1))
    
34.             End If
    
35.             For k = 1 To UBound(arr, 2)
    
36.                 crr(s, k) = arr(x(j), k)
    
37.             Next
    
38.         Next
    
39.         x = Split(d2(a(i)), ",")
    
40.         For j = 0 To UBound(x)
    
41.             s = s + 1
    
42.             If c2 Is Nothing Then
    
43.                 Set c2 = Cells(s, 1)
    
44.             Else
    
45.                 Set c2 = Union(c2, Cells(s, 1))
    
46.             End If
    
47.             For k = 1 To UBound(arr, 2)
    
48.                 crr(s, k) = brr(x(j), k)
    
49.             Next
    
50.         Next
    
51.         s = s + 1
    
52.     End If
    
53. Next
    
54. ActiveSheet.UsedRange.Clear
    
55. Range("a1").Resize(s, UBound(crr, 2)) = crr
    
56. If Not c Is Nothing Then c.Interior.ColorIndex = 6
    
57. If Not c2 Is Nothing Then c2.Interior.ColorIndex = 10
    
58. End Sub

复制代码

dsmch

………………