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

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 求助
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 1926|回复: 6

[已解决]求助

[复制链接]
uuw5
发表于 2012-10-12 14:40 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
求助一个VBA看附件说明 Book1.rar (7.29 KB, 下载次数: 12)
excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
hwc2ycy
发表于 2012-10-12 14:45 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
重复是按列里重复还是行重复， 还是整个区域重复？
回复

使用道具 举报

hwc2ycy
发表于 2012-10-12 15:00 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
本帖最后由 hwc2ycy 于 2012-10-12 15:03 编辑
  1. Sub 重复()
  2.     Dim arr
  3.     Dim arrRst
  4.     Dim dic As Object
  5.     Dim i, j, i1, i2, i3
  6.     Dim dickey
  7.     Application.ScreenUpdating = False
  8.     arr = Range("f5").CurrentRegion.Value
  9.     ReDim arrRst(1 To UBound(arr) * UBound(arr, 2), 1 To 3)
  10.     Set dic = CreateObject("scripting.dictionary")
  11.     For i = 1 To UBound(arr, 2)
  12.         For j = 1 To UBound(arr)
  13.             If arr(j, i) <> "" Then dic(arr(j, i)) = dic(arr(j, i)) + 1
  14.         Next
  15.         For Each dickey In dic.keys
  16.             If dic(dickey) > 0 Then
  17.                 i1 = i1 + 1
  18.                 arrRst(i1, 1) = dickey
  19.             End If
  20.             If dic(dickey) = 2 Then
  21.                 i2 = i2 + 1
  22.                 arrRst(i2, 2) = dickey
  23.             End If
  24.             If dic(dickey) > 2 Then
  25.                 i3 = i3 + 1
  26.                 arrRst(i3, 3) = dickey
  27.             End If
  28.         Next
  29.         dic.RemoveAll
  30.     Next
  31.     [a1].CurrentRegion.ClearContents
  32.     [a1].Resize(UBound(arr), 3).Value = arrRst
  33. End Sub
复制代码
回复

使用道具 举报

hwc2ycy
发表于 2012-10-12 15:04 | 显示全部楼层
Book1-统计个数.rar (17.96 KB, 下载次数: 3)
回复

使用道具 举报

uuw5
 楼主| 发表于 2012-10-12 15:35 | 显示全部楼层
hwc2ycy 发表于 2012-10-12 15:04

跟我想要的不一样,我这个附件有两个VBA只求岀了G和H列的结果,你看了可能明白我要的意思, Book1.rar (12.41 KB, 下载次数: 7)
回复

使用道具 举报

hwc2ycy
发表于 2012-10-12 16:01 | 显示全部楼层
uuw5 发表于 2012-10-12 15:35
跟我想要的不一样,我这个附件有两个VBA只求岀了G和H列的结果,你看了可能明白我要的意思,

只是显示位置不同而已， 关键是统计出来的数字对不对，这才是关键的。
回复

使用道具 举报

hwc2ycy
发表于 2012-10-12 16:09 | 显示全部楼层    本楼为最佳答案   
  1. Sub 重复2()
  2.     Dim arr
  3.     Dim arrRst1, arrRst2, arrRst3
  4.     Dim dic As Object
  5.     Dim i, j, i1, i2, i3
  6.     Dim dickey
  7.     Application.ScreenUpdating = False
  8.     arr = Range("f5").CurrentRegion.Value
  9.     ReDim arrRst1(1 To UBound(arr) * UBound(arr, 2), 1 To 1)
  10.     ReDim arrRst2(1 To UBound(arr) * UBound(arr, 2), 1 To 1)
  11.     ReDim arrRst3(1 To UBound(arr) * UBound(arr, 2), 1 To 1)
  12.     Set dic = CreateObject("scripting.dictionary")
  13.     For i = 1 To UBound(arr, 2)
  14.         For j = 1 To UBound(arr)
  15.             If arr(j, i) <> "" Then dic(arr(j, i)) = dic(arr(j, i)) + 1
  16.         Next
  17.         For Each dickey In dic.keys
  18.             If dic(dickey) > 0 Then
  19.                 i1 = i1 + 1
  20.                 arrRst1(i1, 1) = dickey
  21.             End If
  22.             If dic(dickey) = 2 Then
  23.                 i2 = i2 + 1
  24.                 arrRst2(i2, 1) = dickey
  25.             End If
  26.             If dic(dickey) > 2 Then
  27.                 i3 = i3 + 1
  28.                 arrRst3(i3, 1) = dickey
  29.             End If
  30.         Next
  31.         dic.RemoveAll
  32.     Next
  33.     [a1].CurrentRegion.ClearContents
  34.     [a1].Resize(i1, 1).Value = arrRst1
  35.     [c1].Resize(i2, 1).Value = arrRst2
  36.     [n1].Resize(i3, 1).Value = arrRst3
  37. End Sub
复制代码
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-4-26 07:32 , Processed in 0.182347 second(s), 11 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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