Excel精英培训网

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

[已解决]求个VBA

[复制链接]
发表于 2013-2-1 09:27 | 显示全部楼层 |阅读模式
Book1.rar (22.95 KB, 下载次数: 21)
发表于 2013-2-1 09:51 | 显示全部楼层
  1. Sub test()
  2.     Dim arr, result(), l&, rgitem, arrrg
  3.     arrrg = Array("d15:h300", "e15:i300", "g15:k300")

  4.     Dim dic As Object
  5.     Set dic = CreateObject("scripting.dictionary")

  6.     For Each rgitem In arrrg
  7.         arr = Range(rgitem)
  8.         For Each Item In arr
  9.             dic(Item) = dic(Item) + 1
  10.         Next
  11.         For Each Key In dic.keys
  12.             If dic(Key) = 4 Then
  13.                 l = l + 1
  14.                 ReDim Preserve result(1 To l)
  15.                 result(l) = "'" & Key
  16.             End If
  17.         Next
  18.         dic.RemoveAll
  19.     Next
  20.     Range("w:w").ClearContents
  21.     Range("w1").Resize(l) = WorksheetFunction.Transpose(result)
  22.     MsgBox "提取完成"
  23. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2013-2-1 10:08 | 显示全部楼层
hwc2ycy 发表于 2013-2-1 09:51

D到H, E到I, F到J, G到K, H到L, I到M, J到N, K到O, L到P, M到Q,都是固定5列找重数
回复

使用道具 举报

发表于 2013-2-1 10:13 | 显示全部楼层
fghji 发表于 2013-2-1 10:08
D到H, E到I, F到J, G到K, H到L, I到M, J到N, K到O, L到P, M到Q,都是固定5列找重数

他的代码稍微改变一下就行啦
Sub test()
    Dim arr, result(), l&, rgitem, arrrg
    arrrg = Array("D15:H300", "E15:I300", "F15:J300", "G15:K300", "H15:L300", "I15:M300", _
    "J15:N300", "K15:O300", "L15:P300", "M15:Q300", _
    "N15:R300", "O15:S300", "P15:T300", "Q15:U300")

    Dim dic As Object
    Set dic = CreateObject("scripting.dictionary")

    For Each rgitem In arrrg
        arr = Range(rgitem)
        For Each Item In arr
            dic(Item) = dic(Item) + 1
        Next
        For Each Key In dic.Keys
            If dic(Key) = 4 Then
                l = l + 1
                ReDim Preserve result(1 To l)
                result(l) = "'" & Key
            End If
        Next
        dic.RemoveAll
    Next
    Range("w:w").ClearContents
    Range("w1").Resize(l) = WorksheetFunction.Transpose(result)
    MsgBox "提取完成"
End Sub

回复

使用道具 举报

 楼主| 发表于 2013-2-1 10:22 | 显示全部楼层
JLxiangwei 发表于 2013-2-1 10:13
他的代码稍微改变一下就行啦
Sub test()
    Dim arr, result(), l&, rgitem, arrrg

我只知道从D列开始,每5个连列取重数,到最后有数据的列为止,

点评

你试过了代码吗  发表于 2013-2-1 10:28
回复

使用道具 举报

 楼主| 发表于 2013-2-1 10:53 | 显示全部楼层
fghji 发表于 2013-2-1 10:22
我只知道从D列开始,每5个连列取重数,到最后有数据的列为止,

在哪列为止不是固定的,也许下次在FF为止列呢
回复

使用道具 举报

发表于 2013-2-1 21:44 | 显示全部楼层    本楼为最佳答案   
  1. Option Explicit
  2. Sub test()
  3. '---------------------------------------------------------------------------------------
  4. ' Procedure : test
  5. ' Author    : hwc2ycy
  6. ' Date      : 2013/2/1
  7. ' Purpose   : 应用字典+数组 进行统计
  8. '---------------------------------------------------------------------------------------
  9. '
  10.     '源数据数组,结果数组,结果数组大小,数组元素
  11.     Dim arr, arrResult(), arrSize&, arrItem
  12.     '源数据列,列数循环计数器
  13.     Dim ColSum&, i&
  14.    
  15.     ColSum = Range("d15").CurrentRegion.Columns.Count
  16.     '字典,统计重复数
  17.     Dim dic As Object, Key
  18.     Set dic = CreateObject("scripting.dictionary")
  19.    
  20.     For i = 0 To ColSum - 4
  21.         '取源数据
  22.         arr = Range("d15:h300").Offset(, i).Resize(, 4)
  23.         '统计重复数
  24.         For Each arrItem In arr
  25.             dic(arrItem) = dic(arrItem) + 1
  26.         Next
  27.         '重复数为4的写入结果数组
  28.         For Each Key In dic.keys
  29.             If dic(Key) = 4 Then
  30.                 arrSize = arrSize + 1
  31.                 ReDim Preserve arrResult(1 To arrSize)
  32.                 arrResult(arrSize) = "'" & Key
  33.             End If
  34.         Next
  35.         '清空字典,为下一轮继续
  36.         dic.RemoveAll
  37.     Next
  38.    
  39.     '清除W列
  40.     Range("w:w").ClearContents
  41.     '结果写回单元格
  42.     Range("w1").Resize(arrSize) = WorksheetFunction.Transpose(arrResult)
  43.     Set dic = Nothing
  44.     MsgBox "提取完成,一共有 " & arrSize & " 个重复值", vbInformation + vbOKOnly
  45. End Sub
复制代码
回复

使用道具 举报

发表于 2013-2-1 21:45 | 显示全部楼层
如果统计的区域已经包含了W列的话,就要考虑结果的写入位置了。
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-28 21:23 , Processed in 0.539974 second(s), 14 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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