[已解决]遍历多表固定列不重复

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr(1 To 60000, 1 To 1), drr(1 To 1000)
   
3. Dim s2&, d, d2, w, i%, j&, s&, zf$$
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set d2 = CreateObject("scripting.dictionary")
   
6. Sheets("汇总").Activate
   
7. For i = 1 To Sheets.Count
   
8.     If Sheets(i).Name <> "汇总" And Application.CountA(Sheets(i).UsedRange) > 0 Then
   
9.         s = s + 1
   
10.         arr = Sheets(i).UsedRange
    
11.         zf = Sheets(i).Name
    
12.         drr(s) = "仅" & zf & "有"
    
13.         d2(zf) = s
    
14.         For j = 2 To UBound(arr)
    
15.             If arr(j, 1) = "" Then GoTo line1
    
16.             If Not d.exists(arr(j, 1)) Then
    
17.                 d(arr(j, 1)) = zf
    
18.                 s2 = s2 + 1: crr(s2, 1) = arr(j, 1)
    
19.             Else
    
20.                 If InStr(d(arr(j, 1)), zf) = 0 Then d(arr(j, 1)) = d(arr(j, 1)) & "," & zf
    
21.             End If
    
22. line1:
    
23.         Next
    
24.     End If
    
25. Next
    
26. ReDim brr(1 To 60000, 1 To s + 1)
    
27. ReDim w(1 To s + 1)
    
28. a = d.keys: b = d.items
    
29. For i = 0 To d.Count - 1
    
30.     x = Split(b(i), ",")
    
31.     If UBound(x) = 0 Then
    
32.         n = d2(b(i))
    
33.         w(n) = w(n) + 1: brr(w(n), n) = a(i)
    
34.     End If
    
35.     If UBound(x) = s - 1 Then w(s + 1) = w(s + 1) + 1: brr(w(s + 1), s + 1) = a(i)
    
36. Next
    
37. drr(s + 1) = "各表都有": drr(s + 2) = "各表合并不重复"
    
38. [a1].Resize(1, s + 2) = drr
    
39. Range("a2").Resize(Application.Max(w), s + 1) = brr
    
40. Cells(2, s + 2).Resize(s2) = crr
    
41. End Sub

复制代码