求老师帮写个VBA代码从多表中选择相同及不同数据

lzxdy

efttr55dyf 发表于 2017-10-20 11:06
哈哈没想到weiyingde 友也对此感兴趣,我这里也要感谢你一下,你另写的代码及设置中有一点是让我  一直以来 ...

嘿嘿，确实如此，我只看到了weiyingde 友说的第二个字典重复问题，没注意到第一个重复值遗漏问题，导致结果也不正确。第一个应该是m = IIf(n < 8, 1, Int(n / 8))引起后者覆盖前者从而遗漏，第二个才涉及字典。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("sheet1")
   
7.     .Range("a27:ba32,a34:ba43").ClearContents
   
8.     For j = 1 To 46 Step 9
   
9.       d.RemoveAll
   
10.       For i = 4 To 15 Step 11
    
11.         arr = .Cells(i, j).Resize(10, 8)
    
12.         For x = 1 To UBound(arr)
    
13.           For y = 1 To UBound(arr, 2)
    
14.             If Len(arr(x, y)) <> 0 Then
    
15.               If Not d.exists(arr(x, y)) Then
    
16.                 Set d(arr(x, y)) = CreateObject("scripting.dictionary")
    
17.               End If
    
18.               d(arr(x, y))(i) = ""
    
19.             End If
    
20.           Next
    
21.         Next
    
22.       Next
    
23.       ReDim crr(1 To 6, 1 To 8)
    
24.       ReDim drr(1 To 10, 1 To 8)
    
25.       m1 = 1
    
26.       n1 = 1
    
27.       m2 = 1
    
28.       n2 = 1
    
29.       tt = d.items
    
30.       For Each aa In d.keys
    
31.         If d(aa).Count > 1 Then
    
32.           crr(m1, n1) = aa
    
33.           n1 = n1 + 1
    
34.           If n1 > 8 Then
    
35.             n1 = 1
    
36.             m1 = m1 + 1
    
37.           End If
    
38.         Else
    
39.           drr(m2, n2) = aa
    
40.           n2 = n2 + 1
    
41.           If n2 > 8 Then
    
42.             n2 = 1
    
43.             m2 = m2 + 1
    
44.           End If
    
45.         End If
    
46.       Next
    
47.       .Cells(27, j).Resize(UBound(crr), UBound(crr, 2)) = crr
    
48.       .Cells(34, j).Resize(UBound(drr), UBound(drr, 2)) = drr
    
49.     Next
    
50.   End With
    
51. End Sub
    

复制代码

chxw68

凑凑热闹。

lzxdy

weiyingde 发表于 2017-10-20 16:12
再次测试，发现字典统计的数字也不对，比实际数要多出几个，请测试并指点。

再次看了，之前回答有误。作了4 处修改：
1，crr清空
2、n置零。
3、
4、
见代码：
Sub 对比3()
On Error Resume Next
Dim rg As Range, crr(1 To 10, 1 To 9)
For i = 1 To 6   '---1
For Each rgg In crr
rgg = ""
Next
n = 0
    Set rg = Sheet1.Range("A4:H13").Offset(0, (i - 1) * 9)
    arr = rg.Value
    Set rng = Sheet1.Range("A15:H24").Offset(0, (i - 1) * 9)
    brr = rng.Value
    Set d = CreateObject("scripting.dictionary")
      For Each rn1 In arr
        If rn1 <> "" Then
           For Each rn2 In brr
             If rn2 <> "" Then
                 If rn1 = rn2 Then
                    n = n + 1
                    m = 1 + Int((n - 1) / 8)   '----2
                    p = IIf(n Mod 8 = 0, 8, n Mod 8)
                    crr(m, p) = rn2
                    Set rng1 = Nothing
                    Set rng2 = Nothing
                 Else
                    d(rn1) = ""
                                    '---3
                 End If
             End If
            Next
         End If
         
      Next
    Sheet1.Cells(45, (i - 1) * 9 + 1).Resize(10, 9) = crr
    For Each rn3 In crr   '---4
    d.Remove rn3
    Next
    k = d.keys
    t = d.Count
         For j = 0 To t
           r = Int(j / 8)
           y = j Mod 8
           Sheet1.Cells(55, 1).Offset(r, (i - 1) * 9 + y) = k(j)
         Next
     n = 0
    Set d = Nothing
    Set k = Nothing
Next
MsgBox t
End Sub

乐乐2006201505

efttr55dyf 发表于 2017-10-17 16:00
lzxdy老师您好 自己有些表我都想达到我第二问目的，只是没人指教也没见过类似模板，所以总是有老虎吃天无 ...

其实从3楼代码来看，这个代码的通用性（迁移到其它相同要求，不同区域）还是比较强的。你完全可以自己随意修改区域，达到目的的。

weiyingde

chxw68 发表于 2017-10-20 16:50
凑凑热闹。

谢谢储老师，谢谢。

weiyingde

lzxdy 发表于 2017-10-20 17:14
再次看了，之前回答有误。作了4 处修改：
1，crr清空
2、n置零。

谢谢指教，谢谢。

weiyingde

lzxdy 发表于 2017-10-20 17:14
再次看了，之前回答有误。作了4 处修改：
1，crr清空
2、n置零。

发现数组生成的不重复数有误。佩服你的钻眼精神。

weiyingde

chxw68 发表于 2017-10-20 16:49

储老师的代码，本人消化有点吃力；烦请就我的代码指点一二（见12楼）。
若能帮忙，更易接受，期待指瑕并帮助。
先谢了。

chxw68

weiyingde 发表于 2017-10-20 22:28
储老师的代码，本人消化有点吃力；烦请就我的代码指点一二（见12楼）。
若能帮忙，更易接受，期待指瑕并 ...

仔细看了你的代码，修改了一会又修改成我上面的代码了。