Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 1558|回复: 9

[已解决]求助

[复制链接]
发表于 2013-3-19 16:43 | 显示全部楼层 |阅读模式
book1.rar (12.92 KB, 下载次数: 19)
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2013-3-19 16:47 | 显示全部楼层
标准没写清楚,是最大重复的数量,还是所有重复的加起来啊
回复

使用道具 举报

发表于 2013-3-19 16:58 | 显示全部楼层
  1. Sub test()

  2.     Dim arr1, arr2, arrTemp, a
  3.     Dim i As Long
  4.     Dim j As Byte
  5.     Dim dic As Object
  6.     Application.ScreenUpdating = False
  7.     arr1 = Range("i1").CurrentRegion
  8.     arr2 = Range("i4").CurrentRegion
  9.    

  10.     Set dic = CreateObject("scripting.dictionary")
  11.         
  12.     Columns("a") = ""
  13.     For i = LBound(arr1, 2) To UBound(arr1, 2)
  14.         j = arr1(1, i)
  15.         arrTemp = WorksheetFunction.Index(arr2, 0, i)

  16.         For Each a In arrTemp
  17.             dic(a) = dic(a) + 1
  18.         Next
  19.         For Each a In dic.keys

  20.             If dic(a) <> j Then
  21.                 Debug.Print dic(a)
  22.                 dic.Remove (a)
  23.             End If
  24.         Next
  25.         If dic.Count > 0 Then Range("a" & Cells(Rows.Count, 1).End(xlUp).Row + 1).Resize(dic.Count) = WorksheetFunction.Transpose(dic.keys)
  26.         dic.RemoveAll
  27.     Next
  28.     Application.ScreenUpdating = True
  29.     MsgBox "整理完成"
  30. End Sub
复制代码
回复

使用道具 举报

发表于 2013-3-19 17:01 | 显示全部楼层
  1. Sub 求指定重复数()

  2.     Dim arr1, arr2, arrTemp, a
  3.     Dim i As Long
  4.     Dim j As Byte
  5.     Dim dic As Object
  6.    
  7.     Application.ScreenUpdating = False
  8.    
  9.     '分别是重复次数,统计数据
  10.     arr1 = Range("i1").CurrentRegion
  11.     arr2 = Range("i4").CurrentRegion
  12.    
  13.     '字典
  14.     Set dic = CreateObject("scripting.dictionary")
  15.     '清除A列
  16.     Columns("a") = ""
  17.    
  18.     For i = LBound(arr1, 2) To UBound(arr1, 2)
  19.         '取重复数次
  20.         j = arr1(1, i)
  21.         '取每一列数据
  22.         arrTemp = WorksheetFunction.Index(arr2, 0, i)
  23.         
  24.         '统计重复次数
  25.         For Each a In arrTemp
  26.             dic(a) = dic(a) + 1
  27.         Next
  28.         
  29.         '非指定重复次数的删除
  30.         For Each a In dic.keys
  31.             If dic(a) <> j Then
  32.                 Debug.Print dic(a)
  33.                 dic.Remove (a)
  34.             End If
  35.         Next
  36.         
  37.         '检测字典内数据个数,然后输出
  38.         If dic.Count > 0 Then Range("a" & Cells(Rows.Count, 1).End(xlUp).Row + 1).Resize(dic.Count) = WorksheetFunction.Transpose(dic.keys)
  39.         '字典清空
  40.         dic.RemoveAll
  41.     Next
  42.    
  43.     Application.ScreenUpdating = True
  44.     MsgBox "整理完成"
  45. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2013-3-19 17:05 | 显示全部楼层
徐淑颖 发表于 2013-3-19 16:47
标准没写清楚,是最大重复的数量,还是所有重复的加起来啊

例   I1是"2"指重复数的个数是2个, 假设I3:I100里有3个245,或5个478,   245,478就放到A列去,
回复

使用道具 举报

发表于 2013-3-19 17:10 | 显示全部楼层    本楼为最佳答案   
  1. Sub 求指定重复数()

  2.     Dim arr1, arr2, arrTemp, a
  3.     Dim i As Long
  4.     Dim j As Byte
  5.     Dim dic As Object
  6.     Dim lRow As Long

  7.     lRow = 1
  8.     Application.ScreenUpdating = False

  9.     '分别是重复次数,统计数据
  10.     arr1 = Range("i1").CurrentRegion
  11.     arr2 = Range("i4").CurrentRegion

  12.     '字典
  13.     Set dic = CreateObject("scripting.dictionary")
  14.     '清除A列
  15.     Columns("a") = ""

  16.     For i = LBound(arr1, 2) To UBound(arr1, 2)
  17.         '取重复数次
  18.         j = arr1(1, i)
  19.         '取每一列数据
  20.         arrTemp = WorksheetFunction.Index(arr2, 0, i)

  21.         '统计重复次数
  22.         For Each a In arrTemp
  23.             dic(a) = dic(a) + 1
  24.         Next

  25.         '非指定重复次数的删除
  26.         For Each a In dic.keys
  27.             If dic(a) <> j Then
  28.                 Debug.Print dic(a)
  29.                 dic.Remove (a)
  30.             End If
  31.         Next

  32.         '检测字典内数据个数,然后输出
  33.         If dic.Count > 0 Then
  34.             Range("a" & lRow).Resize(dic.Count) = WorksheetFunction.Transpose(dic.keys)
  35.             lRow = lRow + dic.Count
  36.             '字典清空
  37.         End If
  38.         dic.RemoveAll
  39.     Next

  40.     Application.ScreenUpdating = True
  41.     MsgBox "整理完成"
  42. End Sub
复制代码
输出有问题,改了下。
回复

使用道具 举报

发表于 2013-3-19 17:10 | 显示全部楼层
你那是大于,怪不得人家说你标准不清楚。
回复

使用道具 举报

发表于 2013-3-19 17:12 | 显示全部楼层
  1.         If dic(a) <> j Then
复制代码
现在判断的是真于的,如果条件要改,你自己就改下吧。
回复

使用道具 举报

 楼主| 发表于 2013-3-19 17:13 | 显示全部楼层
hwc2ycy 发表于 2013-3-19 17:10
你那是大于,怪不得人家说你标准不清楚。

我忘记了,不好意思
回复

使用道具 举报

发表于 2013-3-19 18:37 | 显示全部楼层
班班真狠,就一个帖子,水也灌了,最佳也拿了,真乃我辈楷模呀

点评

你这是赤裸裸的灌水。  发表于 2013-3-19 19:25
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-3-28 21:59 , Processed in 0.501119 second(s), 15 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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