ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
数据管理利器Foxtable2022下载 Excel 2016函数公式学习大典 不用妈妈陪默写神器 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 165|回复: 11

[求助] VBA如何找出出现次数最多和第二多的名字

[复制链接]

TA的精华主题

TA的得分主题

发表于 2022-5-14 13:13 | 显示全部楼层 |阅读模式
image.png 找出出现次数最多和第二多的名字 eee.zip (6.11 KB, 下载次数: 17)

TA的精华主题

TA的得分主题

发表于 2022-5-14 13:37 | 显示全部楼层
  1. Sub test()
  2.     Dim i&, arr, d, d1, ast
  3.     Set d = CreateObject("scripting.dictionary")
  4.     Set d1 = CreateObject("scripting.dictionary")
  5.     arr = [a1].CurrentRegion
  6.     For i = 1 To UBound(arr)
  7.         d(arr(i, 1)) = d(arr(i, 1)) + 1
  8.     Next
  9.     arr = d.keys
  10.     For i = 0 To UBound(arr)
  11.         d1(d(arr(i))) = arr(i)
  12.     Next
  13.     arr = d1.keys
  14.     Set ast = CreateObject("System.Collections.ArrayList")
  15.     For i = 0 To UBound(arr)
  16.         ast.Add arr(i)
  17.     Next
  18.     ast.Sort: ast.Reverse
  19.     [b2] = d1(ast(0)): [c2] = d1(ast(1)): [d2] = d1(ast(2)): [e2] = d1(ast(3))
  20. End Sub
复制代码

评分

参与人数 1鲜花 +1 收起 理由
niko88819 + 1 太强大了

查看全部评分

TA的精华主题

TA的得分主题

发表于 2022-5-14 13:55 | 显示全部楼层
  1. sql解法
  2. Sub test()
  3.     Dim sql$, arr
  4.     sql = "select top 4 名字 from (select 名字,count(*) as cnt from [Sheet1$] group by 名字) order by cnt desc"
  5.     arr = GET_SQL(sql, False)
  6.     [b2:e2] = WorksheetFunction.Transpose(arr)
  7. End Sub

  8. Public Function GET_SQL(strSQL As String, Optional HasHeader As Boolean = True) As Variant()
  9.     Dim Cn, Rs, arr(), i%, j%
  10.     Set Cn = CreateObject("ADODB.Connection")
  11.     Set Rs = CreateObject("ADODB.Recordset")
  12.     If Application.Version < 12 Then
  13.         Cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName
  14.     Else
  15.         Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
  16.     End If
  17.     Rs.Open strSQL, Cn, 1, 3
  18.     If HasHeader = True Then
  19.         ReDim arr(0 To Rs.RecordCount, 0 To Rs.Fields.Count - 1)
  20.         For i = 0 To Rs.Fields.Count - 1
  21.            arr(0, i) = Rs.Fields(i).Name
  22.         Next
  23.         For i = 0 To Rs.RecordCount - 1
  24.             For j = 0 To Rs.Fields.Count - 1
  25.                 arr(i + 1, j) = Rs.Fields(j).Value
  26.             Next
  27.             Rs.MoveNext
  28.         Next
  29.     Else
  30.          ReDim arr(0 To Rs.RecordCount - 1, 0 To Rs.Fields.Count - 1)
  31.          For i = 0 To Rs.RecordCount - 1
  32.              For j = 0 To Rs.Fields.Count - 1
  33.                  arr(i, j) = Rs.Fields(j).Value
  34.              Next
  35.              Rs.MoveNext
  36.          Next
  37.          '注意用GetRows方法转置会遇到NULL转置报错的情况
  38.     End If
  39.     GET_SQL = arr
  40.     Cn.Close
  41.     Set Rs = Nothing
  42.     Set Cn = Nothing
  43. End Function

复制代码

评分

参与人数 1鲜花 +1 收起 理由
niko88819 + 1 太强大了

查看全部评分

TA的精华主题

TA的得分主题

发表于 2022-5-14 14:09 | 显示全部楼层
本帖最后由 wangafg011 于 2022-5-14 14:13 编辑

公式 能接受么?=INDEX($A$1:$A$35,1+MATCH(LARGE(UNIQUE(COUNTIF($A$2:$A$35,$A$2:$A$35)),COLUMN(A1)),COUNTIF($A$2:$A$35,$A$2:$A$35),))

TA的精华主题

TA的得分主题

 楼主| 发表于 2022-5-14 14:18 | 显示全部楼层
wangafg011 发表于 2022-5-14 14:09
公式 能接受么?=INDEX($A$1:$A$35,1+MATCH(LARGE(UNIQUE(COUNTIF($A$2:$A$35,$A$2:$A$35)),COLUMN(A1)),CO ...

表太多了,要用代码

TA的精华主题

TA的得分主题

发表于 2022-5-14 15:13 | 显示全部楼层
image.png

//在这里 改出现次数,默认从高到低。
    let oldArr = [1,1,1,1,1,1,1];
默认从高到低,7个表示 从最高的向下依次排6个。

eee.zip

10.55 KB, 下载次数: 3

TA的精华主题

TA的得分主题

发表于 2022-5-14 15:18 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2022-5-14 15:19 | 显示全部楼层
请楼主参考。。。

eee.rar

14.64 KB, 下载次数: 9

TA的精华主题

TA的得分主题

发表于 2022-5-14 15:24 | 显示全部楼层
按名次.rar (14.07 KB, 下载次数: 10)

评分

参与人数 1鲜花 +1 收起 理由
niko88819 + 1 太强大了

查看全部评分

TA的精华主题

TA的得分主题

发表于 2022-5-14 15:56 | 显示全部楼层
本帖最后由 smiletwo 于 2022-5-14 16:01 编辑

image.png

eee.zip

16.43 KB, 下载次数: 8

评分

参与人数 1鲜花 +1 收起 理由
niko88819 + 1 太强大了

查看全部评分

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

本版积分规则

关注官方微信,每天学会一个新技能

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

GMT+8, 2022-5-23 04:06 , Processed in 0.084815 second(s), 22 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2022 Wooffice Inc.

   

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

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

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