[已解决]把每个表中重复行数大于2行的筛选出来

hwc2ycy

ymq123 发表于 2014-4-18 19:47
老师你好，
      我把筛选内容增大了，只有3个表格，但运行时，sh1.Cells(r2, c).Resize(UBound(arr2), ...

说明符合条件的只有一条数据，在转置后就出问题了。

ymq123

hwc2ycy 发表于 2014-4-18 20:40
说明符合条件的只有一条数据，在转置后就出问题了。

请问，怎么才能筛选出所需要的数据，

hwc2ycy

ymq123 发表于 2014-4-18 21:01
请问，怎么才能筛选出所需要的数据，

你现在的工作簿在我这测试并没有问题呀。
数据量太多了。

hwc2ycy

1. Private Sub CommandButton1_Click()
   
2. 
   
3.     Dim arr, arr2
   
4.     Dim objDic As Object, objDic2 As Object
   
5.     Set objDic = CreateObject("scripting.dictionary")
   
6.     Set objDic2 = CreateObject("scripting.dictionary")
   
7.     Dim i&, j&, k&
   
8.     Dim r&, c&, r2&
   
9.     Dim str$, key
   
10.     Dim t#
    
11.     Dim sh As Worksheet, sh1 As Worksheet
    
12.     Set sh = Sheets("1")
    
13.     Set sh1 = Sheets("2")
    
14.     r2 = 1
    
15.     t = Timer
    
16.     Application.ScreenUpdating = False
    
17.     Application.Interactive = False
    
18.     Application.EnableEvents = False
    
19.     For r = 1 To 9346 Step 9346
    
20.         For c = 1 To 29 Step 14
    
21.             With sh.Cells(r, c).Resize(9346, 13)
    
22.                 .SpecialCells(xlCellTypeBlanks).Value = "#"
    
23.                 arr = .Value
    
24.             End With
    
25.             For i = 1 To UBound(arr)
    
26.                 str = ""
    
27.                 For j = 1 To UBound(arr, 2)
    
28.                     str = str & arr(i, j) & "@"
    
29.                 Next
    
30.                 str = Left(str, Len(str) - 1)
    
31.                 objDic(str) = objDic(str) + 1
    
32.             Next
    
33.             For Each key In objDic.keys
    
34.                 If objDic(key) > 3 Then
    
35.                     objDic2.Add objDic2.Count + 1, Split(key, "@")
    
36.                 End If
    
37.             Next
    
38.             If objDic2.Count Then
    
39.                 arr2 = WorksheetFunction.Transpose(WorksheetFunction.Transpose(objDic2.items))
    
40.                 If objDic2.Count = 1 Then
    
41.                     sh1.Cells(r2, c).Resize(, UBound(arr)).Value = arr2
    
42.                 Else
    
43.                     sh1.Cells(r2, c).Resize(UBound(arr), UBound(arr, 2)).Value = arr2
    
44.                 End If
    
45.             End If
    
46.             objDic2.RemoveAll
    
47.             objDic.RemoveAll
    
48.         Next
    
49.         r2 = sh1.UsedRange.Rows.Count + 1
    
50.     Next
    
51.     sh1.UsedRange.Replace "#", ""
    
52.     sh.UsedRange.Replace "#", ""
    
53.     Application.ScreenUpdating = True
    
54.     Application.Interactive = True
    
55.     Application.EnableEvents = True
    
56.     MsgBox "ok"
    
57. End Sub
    

复制代码

关于1个筛选项的更正。

ymq123

hwc2ycy 发表于 2014-4-19 00:27
关于1个筛选项的更正。

老师你好，
  请你调试好后，把附件发给我，我把代码代入后，不能运行。
谢谢！

zhyoucheng

学习

grf1973

1. Private Sub CommandButton1_Click()
   
2.     Dim arr, brr(), d As Object, i&, s&, x%, y&, zf$
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Sheets("2").UsedRange.Clear
   
5.     gs = 5: ReDim zff(1 To gs)        '每行数字中相同的个数
   
6.     For y = 0 To 2
   
7.         With Sheets("1")
   
8.             arr = .Cells(1, 1 + 14 * y).Resize(.UsedRange.Rows.Count, 13)
   
9.         End With
   
10.         
    
11.         ReDim brr(1 To UBound(arr), 1 To gs)
    
12.         For i = 1 To UBound(arr)
    
13.             N = 0
    
14.             For k = 1 To 13
    
15.                 If arr(i, k) > 0 Then N = N + 1: zff(N) = arr(i, k)
    
16.             Next
    
17.             zf = Join(zff, ",")
    
18.             d(zf) = d(zf) + 1
    
19.             If d(zf) = 2 Then
    
20.                 s = s + 1
    
21.                 For x = 1 To gs
    
22.                     brr(s, x) = zff(x)
    
23.                 Next
    
24.             End If
    
25.         Next
    
26.         Sheets("2").Cells(1, 1 + y * 14).Resize(s, gs) = brr
    
27.         s = 0
    
28.         d.RemoveAll
    
29.     Next
    
30. End Sub
    

复制代码