日期范围内出现最多姓名及第二多

jylai

C8开始日期、D8结束日期、d列名字范围、c列日期范围




=MOR(C11:C28,C8,C11:C28,D8,D11:D28,1)


你的帮助不胜激

taller

代码有什么问题？

3190496160

现在的自定义函数是可以实现你需要的效果的呀，

ynzsvt

看出来了，最小的第一名，不是最多的第一名。

ykcbf1100

不想改AI写的代码，新写一个，供参考。。。

ykcbf1100

1. Sub ykcbf()    '//2025.4.7
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With ActiveSheet
   
5.         r = .Cells(Rows.Count, 3).End(xlUp).Row
   
6.         arr = .Range("c10:d" & r)
   
7.         rq1 = .[c8].Value
   
8.         rq2 = .[d8].Value
   
9.         For i = 2 To UBound(arr)
   
10.             If arr(i, 1) >= rq1 And arr(i, 1) <= rq2 Then
    
11.                 s = Trim(arr(i, 2))
    
12.                 d(s) = d(s) + 1
    
13.             End If
    
14.         Next i
    
15.         ReDim brr(1 To d.Count, 1 To 2)
    
16.         For Each k In d.Keys
    
17.             m = m + 1
    
18.             brr(m, 1) = k
    
19.             brr(m, 2) = d(k)
    
20.         Next k
    
21.         For i = LBound(brr, 1) To UBound(brr, 1)
    
22.             For j = i + 1 To UBound(brr, 1)
    
23.                 If brr(j, 2) > brr(i, 2) Then
    
24.                     temp = brr(i, 1)
    
25.                     brr(i, 1) = brr(j, 1)
    
26.                     brr(j, 1) = temp
    
27.                     temp = brr(i, 2)
    
28.                     brr(i, 2) = brr(j, 2)
    
29.                     brr(j, 2) = temp
    
30.                 End If
    
31.             Next j
    
32.         Next i
    
33.         top1 = brr(1, 1)
    
34.         count1 = brr(1, 2)
    
35.         If UBound(brr, 2) >= 1 Then
    
36.             hasSecond = True
    
37.             top2 = brr(2, 1)
    
38.             count2 = brr(2, 2)
    
39.         Else
    
40.             hasSecond = False
    
41.         End If
    
42.         .[f9] = top1
    
43.         .[h9] = top2
    
44.     End With
    
45.     Set d = Nothing
    
46.     Application.ScreenUpdating = True
    
47.     MsgBox "OK！"
    
48. End Sub
    

复制代码

zhangcheng6688

借楼学习一下字典
Sub test()
arr = [c10].CurrentRegion
Set dic = CreateObject("scripting.dictionary")
For i = 2 To UBound(arr)
   If arr(i, 1) >= [c8] And arr(i, 1) <= [d8] Then
      dic(arr(i, 2)) = dic(arr(i, 2)) + 1
   End If
Next
ReDim brr(1 To dic.Count, 1 To 2)
For Each kk In dic.keys
   m = m + 1
   brr(m, 1) = kk
   brr(m, 2) = dic(kk)
Next
For i = 1 To UBound(brr) - 1
   For j = i + 1 To UBound(brr)
      If brr(i, 2) < brr(j, 2) Then
         For k = 1 To UBound(brr, 2)
            temp = brr(j, k): brr(j, k) = brr(i, k): brr(i, k) = temp
         Next
      End If
   Next
Next
[f9] = brr(1, 1)
[h9] = brr(2, 1)
Set dic = Nothing
End Sub

taller

1. ' 不使用字典排序，添加字典元素时可以记录最大值
   
2. ' 删除最大值之后，可以查找次大值
   
3. 
   
4. Function MOR(DateRange1 As Range, StartDate As Date, DateRange2 As Range, EndDate As Date, NameRange As Range, Rank As Integer) As Variant
   
5.     If DateRange1.Cells.Count <> DateRange2.Cells.Count Or DateRange1.Cells.Count <> NameRange.Cells.Count Then
   
6.         MOR = CVErr(xlErrValue)
   
7.         Exit Function
   
8.     End If
   
9.     Dim freqDict As Object
   
10.     Set freqDict = CreateObject("Scripting.Dictionary")
    
11.     Dim i As Long, iMax As Long, sMaxName As String
    
12.     For i = 1 To DateRange1.Cells.Count
    
13.         Dim currentDate1 As Variant
    
14.         currentDate1 = DateRange1.Cells(i).Value
    
15.         Dim currentDate2 As Variant
    
16.         currentDate2 = DateRange2.Cells(i).Value
    
17.         Dim currentName As Variant
    
18.         currentName = NameRange.Cells(i).Value
    
19.         If IsDate(currentDate1) And IsDate(currentDate2) Then
    
20.             Dim d1 As Date
    
21.             d1 = CDate(currentDate1)
    
22.             Dim d2 As Date
    
23.             d2 = CDate(currentDate2)
    
24.             If d1 >= StartDate And d2 <= EndDate Then
    
25.                 If freqDict.Exists(currentName) Then
    
26.                     freqDict(currentName) = freqDict(currentName) + 1
    
27.                     If freqDict(currentName) > iMax Then
    
28.                         iMax = freqDict(currentName)
    
29.                         sMaxName = currentName
    
30.                     End If
    
31.                 Else
    
32.                     freqDict.Add currentName, 1
    
33.                 End If
    
34.             End If
    
35.         End If
    
36.     Next i
    
37.     If freqDict.Count = 0 Then
    
38.         MOR = CVErr(xlErrNA)
    
39.         Exit Function
    
40.     End If
    
41.     MOR = ""
    
42.     If rank = 1 Then
    
43.         MOR = sMaxName
    
44.     Elseif rank = 2 Then
    
45.         freqDict.Remove sMaxName
    
46.         Dim counts: counts = freqDict.Items
    
47.         iMax = Application.Max(counts)
    
48.         Dim vKey
    
49.         For Each vKey In freqDict.Keys
    
50.             If freqDict(vKey) = iMax Then
    
51.                 sMaxName = vKey
    
52.                 Exit For
    
53.             End If
    
54.         Next vKey        
    
55.         MOR = sMaxName
    
56.     End If
    
57. End Function

复制代码

jylai

多谢楼上老师

sdytsxd991122