[已解决]筛选出工作表1中各两表之间数字不相同的行

ymq123

请编写程序
     1、 在工作表1中，把表1与表2中不相同数字的行筛选出来，删除它们之间相同数字的行，表1筛选出来的内容放到工作表2表1内，表2筛选出来的内容放到工作表2表2内。同样，筛选出表3与表4、表5与表6、表7与表8、表9与表10、表11与表12数字不相同的行，把筛选的结果放到 工作表2中对应的表格里。
       2、工作表1里各表56行，工作表2内各表51行。（关键是不知道把筛选结果，怎么才能放到工作表2对应表格里）
谢谢！

最佳答案

月排行榜 / 总排行榜

grf1973

2014-4-29 13:46

1. Private Sub CommandButton1_Click()
   
2.     Dim arr1(), arr2(), brr1(), brr2()
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set d1 = CreateObject("scripting.dictionary")
   
5.     With Sheets("2")
   
6.         .Range("a:i,o:w,ac:ak").ClearContents
   
7.         For y = 0 To 2
   
8.             For x = 1 To 2
   
9.                 mc = 1 + y * 14   '原始数所在的列
   
10.                 mr = IIf(x = 1, 1, 115)  '原始数所在的行
    
11.                 arr1 = Getarr(mr, mc): brr1 = GetBrr(arr1) '表1，去重
    
12.                 arr2 = Getarr(mr + 57, mc): brr2 = GetBrr(arr2) '表2，去重
    
13.                 r1 = UBound(brr1): c = UBound(brr1, 2)
    
14.                 r2 = UBound(brr2)
    
15.                
    
16.                 Dim DelRng As Range
    
17.                 With Sheet3
    
18.                     .UsedRange.ClearContents
    
19.                     Set DelRng = .Cells(10000, 1).Resize(1, 9)
    
20.                     .[a1].Resize(r1, c) = brr1
    
21.                     .Cells(r1 + 2, 1).Resize(UBound(brr2), c) = brr2
    
22.                     For i = 1 To UBound(brr1)   '表1+表2去重
    
23.                         zf = Join(Application.Index(brr1, i), "")
    
24.                         If Len(zf) > 0 Then d(zf) = i
    
25.                     Next
    
26.                     
    
27.                     k = 0    'k表示表1、表2各自配对数（表1或表2中删掉的行数）
    
28.                     For i = 1 To UBound(brr2)
    
29.                         zf = Join(Application.Index(brr2, i), "")
    
30.                         If d.exists(zf) Then   '表1、表2中有数相同
    
31.                             k = k + 1
    
32.                             Set DelRng = Union(DelRng, .Cells(d(zf), 1).Resize(1, 9), .Cells(i + r1 + 2, 1).Resize(1, 9))
    
33.                         End If
    
34.                     Next
    
35.                     DelRng.Delete shift:=xlUp
    
36.                  End With
    
37.                  
    
38.                  xr = IIf(x = 1, 1, 105)  '显示结果所在的行
    
39.                 .Cells(xr, mc).Resize(r1 - k, 9) = Sheet3.Cells(1, 1).Resize(r1 - k, 9).Value
    
40.                 .Cells(xr + 52, mc).Resize(51, 9) = Sheet3.Cells(r1 - k + 2, 1).Resize(51, 9).Value
    
41.             Next
    
42.         Next
    
43.     End With
    
44. End Sub
    
45. 
    
46. Function Getarr(r, c)  '取得cells(r,c)为左上角的数组（56*9）
    
47.     ReDim arr(1 To 56, 1 To 9)
    
48.     xarr = Sheet1.Cells(r, c).Resize(56, 9)
    
49.     For i = 1 To 56
    
50.         For j = 1 To 9
    
51.             arr(i, j) = xarr(i, j)
    
52.         Next
    
53.     Next
    
54.     Getarr = arr
    
55. End Function
    
56. 
    
57. Function GetBrr(arr())   '数组arr中去掉相同行
    
58.         Set d = CreateObject("scripting.dictionary")
    
59.         ReDim zff(1 To UBound(arr, 2))
    
60.         ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
61.         For i = 1 To UBound(arr)
    
62.             For k = 1 To UBound(arr, 2)
    
63.                 zff(k) = arr(i, k)
    
64.             Next
    
65.             zf = Join(zff, ",")
    
66.             d(zf) = d(zf) + 1    '记录重复次数
    
67.         Next
    
68.         dk = d.keys: dt = d.items
    
69.         For i = 0 To UBound(dk)
    
70.             If dt(i) = 1 Then
    
71.                 s = s + 1
    
72.                 For x = 1 To UBound(arr, 2)
    
73.                     brr(s, x) = Split(dk(i), ",")(x - 1)
    
74.                 Next
    
75.             End If
    
76.         Next
    
77.         GetBrr = brr
    
78. End Function

复制代码

跳转到最佳答案楼层

grf1973

1. Private Sub CommandButton1_Click()
   
2.     Dim arr1(), arr2(), brr1(), brr2()
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set d1 = CreateObject("scripting.dictionary")
   
5.     With Sheets("2")
   
6.         .Range("a:i,o:w,ac:ak").ClearContents
   
7.         For y = 0 To 2
   
8.             For x = 1 To 2
   
9.                 mc = 1 + y * 14   '原始数所在的列
   
10.                 mr = IIf(x = 1, 1, 115)  '原始数所在的行
    
11.                 arr1 = Getarr(mr, mc): brr1 = GetBrr(arr1) '表1，去重
    
12.                 arr2 = Getarr(mr + 57, mc): brr2 = GetBrr(arr2) '表2，去重
    
13.                 r1 = UBound(brr1): c = UBound(brr1, 2)
    
14.                 r2 = UBound(brr2)
    
15.                
    
16.                 Dim DelRng As Range
    
17.                 With Sheet3
    
18.                     .UsedRange.ClearContents
    
19.                     Set DelRng = .Cells(10000, 1).Resize(1, 9)
    
20.                     .[a1].Resize(r1, c) = brr1
    
21.                     .Cells(r1 + 2, 1).Resize(UBound(brr2), c) = brr2
    
22.                     For i = 1 To UBound(brr1)   '表1+表2去重
    
23.                         zf = Join(Application.Index(brr1, i), "")
    
24.                         If Len(zf) > 0 Then d(zf) = i
    
25.                     Next
    
26.                     
    
27.                     k = 0    'k表示表1、表2各自配对数（表1或表2中删掉的行数）
    
28.                     For i = 1 To UBound(brr2)
    
29.                         zf = Join(Application.Index(brr2, i), "")
    
30.                         If d.exists(zf) Then   '表1、表2中有数相同
    
31.                             k = k + 1
    
32.                             Set DelRng = Union(DelRng, .Cells(d(zf), 1).Resize(1, 9), .Cells(i + r1 + 2, 1).Resize(1, 9))
    
33.                         End If
    
34.                     Next
    
35.                     DelRng.Delete shift:=xlUp
    
36.                  End With
    
37.                  
    
38.                  xr = IIf(x = 1, 1, 105)  '显示结果所在的行
    
39.                 .Cells(xr, mc).Resize(r1 - k, 9) = Sheet3.Cells(1, 1).Resize(r1 - k, 9).Value
    
40.                 .Cells(xr + 52, mc).Resize(51, 9) = Sheet3.Cells(r1 - k + 2, 1).Resize(51, 9).Value
    
41.             Next
    
42.         Next
    
43.     End With
    
44. End Sub
    
45. 
    
46. Function Getarr(r, c)  '取得cells(r,c)为左上角的数组（56*9）
    
47.     ReDim arr(1 To 56, 1 To 9)
    
48.     xarr = Sheet1.Cells(r, c).Resize(56, 9)
    
49.     For i = 1 To 56
    
50.         For j = 1 To 9
    
51.             arr(i, j) = xarr(i, j)
    
52.         Next
    
53.     Next
    
54.     Getarr = arr
    
55. End Function
    
56. 
    
57. Function GetBrr(arr())   '数组arr中去掉相同行
    
58.         Set d = CreateObject("scripting.dictionary")
    
59.         ReDim zff(1 To UBound(arr, 2))
    
60.         ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
61.         For i = 1 To UBound(arr)
    
62.             For k = 1 To UBound(arr, 2)
    
63.                 zff(k) = arr(i, k)
    
64.             Next
    
65.             zf = Join(zff, ",")
    
66.             d(zf) = d(zf) + 1    '记录重复次数
    
67.         Next
    
68.         dk = d.keys: dt = d.items
    
69.         For i = 0 To UBound(dk)
    
70.             If dt(i) = 1 Then
    
71.                 s = s + 1
    
72.                 For x = 1 To UBound(arr, 2)
    
73.                     brr(s, x) = Split(dk(i), ",")(x - 1)
    
74.                 Next
    
75.             End If
    
76.         Next
    
77.         GetBrr = brr
    
78. End Function

复制代码

grf1973

用了2个函数子程序。用了辅助工作表，不然太麻烦了。看看结果是否正确。