设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 把每个表中重复行数大于2行的筛选出来
数据透视表40+个常用小技巧，让你一次学会！
12下一页
返回列表 发新帖
查看: 4221|回复: 16

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

[复制链接]
ymq123
发表于 2014-4-18 11:47 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
请编写代码:
   1、 利用for循环，同时对上面6个表进行筛选，筛选后的数字放到工作表2中.
   2、筛选要求：请把各表中数字相同的行大于2行的筛选出来，放到工作表2中。
   3、代码窗口里代码运行比较慢，请老师编写出较快的代码。
谢谢！
最佳答案
月排行榜 / 总排行榜
hwc2ycy
2014-4-18 14:32
  1. Sub test()
  2.     Dim arr, arr2
  3.     Dim objDic As Object, objDic2 As Object
  4.     Set objDic = CreateObject("scripting.dictionary")
  5.     Set objDic2 = CreateObject("scripting.dictionary")
  6.     Dim i As Byte, j As Byte, k As Byte
  7.     Dim r As Byte, c As Byte, r2 As Byte
  8.     On Error Resume Next
  9.     Dim str$, key
  10.     Dim t#
  11.     t = Timer
  12.     r2 = 1
  13.     Application.ScreenUpdating = False
  14.     Sheet3.UsedRange.ClearContents
  15.     For r = 1 To 47 Step 23
  16.         For c = 1 To 33 Step 16
  17.             With Sheet2.Cells(r, c).Resize(22, 11)
  18.                 .SpecialCells(xlCellTypeBlanks).Value = "#"
  19.                 arr = .Value
  20.                 Debug.Print .Address
  21.             End With
  22.             For i = 1 To UBound(arr)
  23.                 str = ""
  24.                 For j = 1 To UBound(arr, 2)
  25.                     str = str & arr(i, j) & "@"
  26.                 Next
  27.                 str = Left(str, Len(str) - 1)
  28.                 objDic(str) = objDic(str) + 1
  29.             Next
  30.             For Each key In objDic.keys
  31.                 If objDic(key) > 2 Then
  32.                     objDic2.Add objDic2.Count + 1, Split(key, "@")
  33.                 End If
  34.             Next
  35.             If objDic2.Count Then
  36.                 arr2 = WorksheetFunction.Transpose(WorksheetFunction.Transpose(objDic2.items))
  37.                 Sheet3.Cells(r2, c).Resize(UBound(arr2), UBound(arr2, 2)).Value = arr2
  38.             End If
  39.             objDic2.RemoveAll
  40.             objDic.RemoveAll

  42.         Next
  43.         r2 = r2 + 8
  44.     Next
  45.     Sheet3.UsedRange.Replace "#", ""
  46.     Sheet2.UsedRange.Replace "#", ""
  47.     Application.ScreenUpdating = True
  48.     MsgBox "处理完成" & vbCr & "用时 " & Timer - t & "秒"
  49. End Sub
复制代码

把每个表中重复行数大于2行的筛选出来.rar

27.38 KB, 阅读权限: 19, 下载次数: 1
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
hwc2ycy
发表于 2014-4-18 12:55 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
  1. Sub test()
  2.     Dim arr
  3.     Dim objDic As Object, objDic2 As Object
  4.     Set objDic = CreateObject("scripting.dictionary")
  5.     Set objDic2 = CreateObject("scripting.dictionary")
  6.     Dim i As Byte, j As Byte, k As Byte
  7.     Dim r As Byte, c As Byte
  8.     On Error Resume Next
  9.     Dim str$, key
  10.     Dim t#
  11.     t = Timer
  12.     Application.ScreenUpdating = False
  13.     For c = 1 To 33 Step 16
  14.         For r = 1 To 24 Step 23
  15.             With Sheet2.Cells(r, c).Resize(22, 11)
  16.                 .SpecialCells(xlCellTypeBlanks).Value = "#"
  17.                 arr = .Value
  18.                 Debug.Print .Address
  19.             End With

  21.             objDic.remoevall
  22.             For i = 1 To UBound(arr)
  23.                 str = ""
  24.                 For j = 1 To UBound(arr, 2)
  25.                     str = str & arr(i, j) & "@"
  26.                 Next
  27.                 str = Left(str, Len(str) - 1)
  28.                 objDic(str) = objDic(str) + 1
  29.             Next
  30.             For Each key In objDic.keys
  31.                 If objDic(key) > 2 Then
  32.                     objDic2.Add objDic2.Count + 1, Split(key, "@")
  33.                 End If
  34.             Next
  35.             Debug.Print Timer - t & "秒"
  36.         Next
  37.     Next
  38.     arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(objDic2.items))
  39.     If objDic2.Count Then
  40.         With Sheet3
  41.             .UsedRange.ClearContents
  42.             .Range("a1").Resize(UBound(arr), UBound(arr, 2)).Value = arr
  43.             .UsedRange.Replace "#", ""
  44.         End With
  45.     End If
  46.     Sheet2.UsedRange.Replace "#", ""
  47.     Application.ScreenUpdating = True
  48.     MsgBox "处理完成" & vbCr & "用时 " & Timer - t & "秒"
  49. End Sub
复制代码
回复

使用道具 举报

ymq123
 楼主| 发表于 2014-4-18 13:51 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
hwc2ycy 发表于 2014-4-18 12:55

分别对6个表进行筛选，筛选出各表相同数字的行，如果相同数字行数大于2行就筛选出来，放到工作表2里。
附件工作表2是筛选的结果，请做参考。
谢谢！

把每个表中重复行数大于2行的筛选出来.rar

27.38 KB, 下载次数: 9
回复

使用道具 举报

grf1973
发表于 2014-4-18 14:23 | 显示全部楼层
真心没弄懂 “数字相同的行大于2行的”。。。。。。。。。
回复

使用道具 举报

hwc2ycy
发表于 2014-4-18 14:32 | 显示全部楼层    本楼为最佳答案   
  1. Sub test()
  2.     Dim arr, arr2
  3.     Dim objDic As Object, objDic2 As Object
  4.     Set objDic = CreateObject("scripting.dictionary")
  5.     Set objDic2 = CreateObject("scripting.dictionary")
  6.     Dim i As Byte, j As Byte, k As Byte
  7.     Dim r As Byte, c As Byte, r2 As Byte
  8.     On Error Resume Next
  9.     Dim str$, key
  10.     Dim t#
  11.     t = Timer
  12.     r2 = 1
  13.     Application.ScreenUpdating = False
  14.     Sheet3.UsedRange.ClearContents
  15.     For r = 1 To 47 Step 23
  16.         For c = 1 To 33 Step 16
  17.             With Sheet2.Cells(r, c).Resize(22, 11)
  18.                 .SpecialCells(xlCellTypeBlanks).Value = "#"
  19.                 arr = .Value
  20.                 Debug.Print .Address
  21.             End With
  22.             For i = 1 To UBound(arr)
  23.                 str = ""
  24.                 For j = 1 To UBound(arr, 2)
  25.                     str = str & arr(i, j) & "@"
  26.                 Next
  27.                 str = Left(str, Len(str) - 1)
  28.                 objDic(str) = objDic(str) + 1
  29.             Next
  30.             For Each key In objDic.keys
  31.                 If objDic(key) > 2 Then
  32.                     objDic2.Add objDic2.Count + 1, Split(key, "@")
  33.                 End If
  34.             Next
  35.             If objDic2.Count Then
  36.                 arr2 = WorksheetFunction.Transpose(WorksheetFunction.Transpose(objDic2.items))
  37.                 Sheet3.Cells(r2, c).Resize(UBound(arr2), UBound(arr2, 2)).Value = arr2
  38.             End If
  39.             objDic2.RemoveAll
  40.             objDic.RemoveAll

  42.         Next
  43.         r2 = r2 + 8
  44.     Next
  45.     Sheet3.UsedRange.Replace "#", ""
  46.     Sheet2.UsedRange.Replace "#", ""
  47.     Application.ScreenUpdating = True
  48.     MsgBox "处理完成" & vbCr & "用时 " & Timer - t & "秒"
  49. End Sub
复制代码
回复

使用道具 举报

hwc2ycy
发表于 2014-4-18 14:35 | 显示全部楼层
  1. Sub test()
  2.     Dim arr, arr2
  3.     Dim objDic As Object, objDic2 As Object
  4.     Set objDic = CreateObject("scripting.dictionary")
  5.     Set objDic2 = CreateObject("scripting.dictionary")
  6.     Dim i As Byte, j As Byte, k As Byte
  7.     Dim r As Byte, c As Byte, r2 As Byte
  8.     On Error Resume Next
  9.     Dim str$, key
  10.     Dim t#
  11.     t = Timer
  12.     r2 = 1
  13.     Application.ScreenUpdating = False
  14.     Sheet3.UsedRange.ClearContents
  15.     For r = 1 To 47 Step 23
  16.         For c = 1 To 33 Step 16
  17.             With Sheet2.Cells(r, c).Resize(22, 11)
  18.                 .SpecialCells(xlCellTypeBlanks).Value = "#"
  19.                 arr = .Value
  20.                 Debug.Print .Address
  21.             End With
  22.             For i = 1 To UBound(arr)
  23.                 str = ""
  24.                 For j = 1 To UBound(arr, 2)
  25.                     str = str & arr(i, j) & "@"
  26.                 Next
  27.                 str = Left(str, Len(str) - 1)
  28.                 objDic(str) = objDic(str) + 1
  29.             Next
  30.             For Each key In objDic.keys
  31.                 If objDic(key) > 2 Then
  32.                     objDic2.Add objDic2.Count + 1, Split(key, "@")
  33.                 End If
  34.             Next
  35.             If objDic2.Count Then
  36.                 arr2 = WorksheetFunction.Transpose(WorksheetFunction.Transpose(objDic2.items))
  37.                 Sheet3.Cells(r2, c).Resize(UBound(arr2), UBound(arr2, 2)).Value = arr2
  38.             End If
  39.             objDic2.RemoveAll
  40.             objDic.RemoveAll

  42.         Next
  43.         r2 = Sheet3.UsedRange.Rows.Count + 5
  44.     Next
  45.     Sheet3.UsedRange.Replace "#", ""
  46.     Sheet2.UsedRange.Replace "#", ""
  47.     Application.ScreenUpdating = True
  48.     MsgBox "处理完成" & vbCr & "用时 " & Timer - t & "秒"
  49. End Sub
复制代码

评分

参与人数 1 +3 收起 理由
ymq123 + 3

查看全部评分

回复

使用道具 举报

grf1973
发表于 2014-4-18 14:57 | 显示全部楼层
  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.     For y = 0 To 2
  6.         For y1 = 0 To 2
  7.             With Sheets("1")
  8.                 arr = .Range(.Cells(1 + 23 * y, 1 + 16 * y1), .Cells(22 + 23 * y, 11 + 16 * y1)).Value
  9.             End With
  10.             
  11.             ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
  12.             For i = 1 To UBound(arr)
  13.                 zf = Join(Application.Index(arr, i, 0), ",")
  14.                 d(zf) = d(zf) + 1
  15.                 If d(zf) = 2 Then
  16.                     s = s + 1
  17.                     For x = 1 To UBound(arr, 2)
  18.                         brr(s, x) = arr(i, x)
  19.                     Next
  20.                 End If
  21.             Next
  22.             Sheets("2").Cells(1 + 9 * y, 1 + y1 * 16).Resize(s, UBound(brr, 2)) = brr
  23.             s = 0
  24.             d.RemoveAll
  25.         Next
  26.     Next
  27. End Sub
复制代码
回复

使用道具 举报

grf1973
发表于 2014-4-18 15:00 | 显示全部楼层
在你代码的基础上改了一下，字典累加后，只在字典item为2的时候，才对brr赋值。
回复

使用道具 举报

grf1973
发表于 2014-4-18 15:04 | 显示全部楼层
字典item为2的时候表示：
1、该行数字有重复
2、第3次以上的重复不再重新计算
我觉得这个思路挺好的。。。。。。。。。和你原来代码的运算结果相比，第一排3个表的结果有出入，第二、第三排的都一样。可我觉得我的运算结果是对的。。。。。

把每个表中重复行数大于2行的筛选出来.rar

34.55 KB, 下载次数: 7
回复

使用道具 举报

ymq123
 楼主| 发表于 2014-4-18 19:47 | 显示全部楼层
hwc2ycy 发表于 2014-4-18 14:35

老师你好，
      我把筛选内容增大了，只有3个表格，但运行时，sh1.Cells(r2, c).Resize(UBound(arr2), UBound(arr2, 2)).Value = arr2出现下标越界。
      请老师帮助修改。
谢谢！

修改筛选出相同行数大于2行的代码.rar

974.07 KB, 下载次数: 5
回复

使用道具 举报

下一页 »
12下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-4-25 07:39 , Processed in 0.575267 second(s), 14 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表