ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 651|回复: 2

[分享] 统计每列每位数的间隔规律及相应的出现次数

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-1-23 00:53 | 显示全部楼层 |阅读模式
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
    前几天发了一个求助贴,见:统计每位数(每列)的间隔规律及相应的次数,多谢各位的热心指点启发,自己把它代码写出来了,能顺利实现要求的功能,从中也学到不少知识。应该不是最优解,但终于可以用了,有需要和感兴趣的一起探讨(代码见sheet2表)。祝大家鼠年平安吉祥!!

    Sub 统计数字走势()
     Dim i%, d, arr(), j%, k%, m%, e%
     Set d = CreateObject("Scripting.Dictionary") '设置字典对象,用于存放不同出现次数的key和item
     arr() = Sheet2.Range("a2:a202")
'********************************************************************************************************
'设置3个嵌套循环,K循环从0-9,代表0-9 10个数字;
'i循环从第一个0开始,J循环从第一个0后的数字开始,依次进行比对,如同相同放入字典;如果不同循环继续,直到最后一个0。
'********************************************************************************************************
       For k = 0 To 9
       m = Application.WorksheetFunction.Match(k, arr(), 0) '确定K在数组中第一次出现的初始位置,用match函数处理;目的是确认i,j循环的起始点
       On Error Resume Next
       e = Sheet2.Columns(1).Find(what:=k, SearchDirection:=2).Row '确定K在第1列中(即arr()数组中)最后一次出现的初始位置,用find函数处理
'设置参数e目的是设立循环终止和i,j循环变更重新赋值的判断条件

         For i = m To UBound(arr) - 1
           If i >= e Then
            i = m
              Exit For
           End If        
         For j = (m + 1) To UBound(arr)         
         If arr(i, 1) <> arr(j, 1) Then         
         GoTo 15         
         ElseIf arr(i, 1) = arr(j, 1) Then         
           d(arr(i, 1) & "间隔" & (j - i - 1) & "期") = d(arr(i, 1) & "间隔" & (j - i - 1) & "期") + 1
            i = j '如果arr(i, 1) = arr(j, 1)表明出现了两个相同的数,此时将J值赋给I,从J中继继续循环   
            If j >= e Then
            j = m + 1
            Exit For
            End If            
        End If        
15:       Next j
         Next i
    Next k
     [l2].Resize(d.Count, 1) = Application.Transpose(d.keys)     
     [m2].Resize(d.Count, 1) = Application.Transpose(d.items)   
End Sub

七星彩自动更新开奖数据的excel文件(原始).rar

184.49 KB, 下载次数: 17

统计位数字走势及次数

TA的精华主题

TA的得分主题

发表于 2020-1-23 08:11 | 显示全部楼层
  1. Sub 按钮26_Click()
  2.     Set d = CreateObject("scripting.dictionary")
  3.     Set dd = CreateObject("scripting.dictionary")
  4.     r = Cells(Rows.Count, 1).End(3).Row
  5.     arr = [a1].Resize(r)
  6.     For j = 2 To UBound(arr)
  7.         d(arr(j, 1)) = d(arr(j, 1)) & "@" & j
  8.     Next j
  9.     For j = 0 To 9
  10.         If d.exists(j) Then
  11.             arr = Split(d(j), "@")
  12.             If UBound(arr) = 1 Then
  13.                 dd(j & "仅仅出现一次") = 0
  14.             Else
  15.                 For i = 1 To UBound(arr) - 1
  16.                     dd(j & "间隔" & Val(arr(i + 1)) - Val(arr(i)) & "期") = dd(j & "间隔" & Val(arr(i + 1)) - Val(arr(i)) & "期") + 1
  17.                 Next i
  18.             End If
  19.         End If
  20.     Next j
  21.     [p2].Resize(dd.Count) = WorksheetFunction.Transpose(dd.keys)
  22.     [q2].Resize(dd.Count) = WorksheetFunction.Transpose(dd.items)
  23. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2020-1-23 08:11 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-28 18:00 , Processed in 0.038675 second(s), 9 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

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