按要求返回指定周期内出现次数最多的数据名称

WYS67

  恳请老师们编写一个 按要求返回指定周期内出现次数最多的数据名称的自定义函数，运算规则和要求都在附件里。

按要求返回指定周期内出现次数最多的数据名称.zip (165.93 KB, 下载次数: 10)

2019-1-21 09:39 上传

点击文件名下载附件

WYS67

恳请老师们帮忙！

WYS67

恳请老师们帮忙！

WYS67

恳请老师们帮忙！

WYS67

恳请老师们帮忙！

lsdongjh

1. 
   
2. Function ZQMODE(rgData As Range, varMax As Variant, varType As Variant) As Variant
   
3.     Dim arr As Variant, lngRow As Long
   
4.     Dim objDic As Object
   
5.     Dim lngCount As Long, lngMax As Long
   
6.     Dim arrKeys As Variant, arrItems As Variant
   
7.     Dim lngVal As Long, strLastVal As String, lngR As Long
   
8.     Dim strResult As String, intDisplay As Integer, lngIndex As Long
   
9.     Dim arrResult As Variant, lngID As Long
   
10.    
    
11.     Set objDic = CreateObject("Scripting.Dictionary")
    
12.     arr = rgData
    
13.     ReDim arrResult(LBound(arr) To UBound(arr), 1 To 1) As String
    
14.    
    
15.     lngMax = varMax
    
16.     intDisplay = varType
    
17.    
    
18.     If lngMax < 3 Then Exit Function
    
19.     If intDisplay <> 0 And intDisplay <> 1 Then Exit Function
    
20.    
    
21.     For lngRow = LBound(arr) To UBound(arr)
    
22.         If arr(lngRow, 1) <> "" Then
    
23.             lngCount = lngCount + 1
    
24.             objDic(arr(lngRow, 1)) = objDic(arr(lngRow, 1)) + 1
    
25.         End If
    
26.         
    
27.         If lngCount = lngMax Then
    
28.             lngIndex = lngIndex + 1
    
29.             If objDic.Count = lngMax Then
    
30.                 strResult = "9"
    
31.             Else
    
32.                 arrKeys = objDic.keys
    
33.                 arrItems = objDic.items
    
34.                 lngVal = arrItems(LBound(arrItems))
    
35.                 strResult = arrKeys(LBound(arrKeys))
    
36.                 For lngR = LBound(arrItems) + 1 To UBound(arrItems)
    
37.                     If arrItems(lngR) > lngVal Then
    
38.                         lngVal = arrItems(lngR)
    
39.                         strResult = arrKeys(lngR)
    
40.                     ElseIf arrItems(lngR) = lngVal Then
    
41.                         If arrKeys(lngR) = strLastVal Then
    
42.                             lngVal = arrItems(lngR)
    
43.                             strResult = arrKeys(lngR)
    
44.                         End If
    
45.                     End If
    
46.                 Next
    
47.             End If
    
48.             lngCount = 0
    
49.             objDic.RemoveAll
    
50.             
    
51.             If intDisplay = 1 Then
    
52.                 lngID = lngRow
    
53.             Else
    
54.                 lngID = lngIndex
    
55.             End If
    
56.             
    
57.             arrResult(lngID, 1) = strResult
    
58.             strLastVal = strResult
    
59.         End If
    
60.         
    
61.     Next
    
62.    
    
63.     Set objDic = Nothing
    
64.     ZQMODE = arrResult
    
65. End Function
    

复制代码

WYS67

lsdongjh 发表于 2019-1-21 14:13

经测试，结果正确，运算速度很快！谢谢老师的大作！