[已解决]请教老师：查找最多数

lygyjt · 发表于 2021-4-7 21:48

本帖最后由 lygyjt 于 2021-4-8 12:43 编辑

请教老师：
A列是序号，原始数组1~10列（此数组是7列）N行，文本型数据，数据范围01~99。
第1步：找出原始数组中存在个数最多的那个数（称为最多数），包括对应的序号（最小的那个序号）；要有并列最多的，列出并列最多数（也算最多数的一种），按从小到大的顺序排列。包括对应的序号（最小的那个序号）。
第2步：原始数组中，删除上面最多数所在行，形成新的原始数组。重复第1步。
第3步，如果最多数存在的个数=1，列出此原始数组所有数据，包括序号。

右面是参考答案。红色字是解释，它最终结果里不需要显示。

查找最多数.rar (11.92 KB, 下载次数: 3)

cutecpu · 发表于 2021-4-7 21:49

这个最佳答案由 cutecpu 给出，感谢 cutecpu 的回答。

单击隐藏图章

Sub demo()
bh = Range("b1:h" & Cells(Rows.Count, "b").End(xlUp).Row)
ReDim r(1 To UBound(bh))
ReDim n2r(1 To 99, 1 To UBound(bh))
ReDim c(1 To 99)
For i = 1 To UBound(bh)
   r(i) = 2
   For j = 1 To 7
      n2r(bh(i, j), i) = 1
      c(bh(i, j)) = c(bh(i, j)) + 1
   Next
Next
o = 1
Do While 1
   Max = WorksheetFunction.Max(c)
   If Max = 1 Then Exit Do
   For i = 1 To 99
      If c(i) = Max Then
         Min = 0
         For j = 1 To UBound(bh)
            If n2r(i, j) Then r(j) = 1: Min = IIf(Min = 0, j, Min)
         Next
         o = o + 1
         Cells(o, "o").Value = Min
         Cells(o, "p").Value = i
      End If
   Next
   For i = 1 To UBound(bh)
      If r(i) = 1 Then
         For j = 1 To 7
            n2r(bh(i, j), i) = 0
            c(bh(i, j)) = c(bh(i, j)) - 1
         Next
         r(i) = 0
      End If
   Next
Loop
For i = 1 To UBound(bh)
   If r(i) Then
      o = o + 1
      Cells(o, "o").Value = i
      Cells(o, "p").Resize(1, 7) = Application.Index(bh, i, 0)
   End If
Next
End Sub

祝順心，南無阿彌陀佛！

砂海 · 发表于 2021-4-7 22:34

貌似彩票

lygyjt · 发表于 2021-4-8 12:43

cutecpu 发表于 2021-4-7 23:53
Sub demo()
bh = Range("b1:h" & Cells(Rows.Count, "b").End(xlUp).Row)
ReDim r(1 To UBound(bh) ...

谢谢版主的指教啊！这么晚了，还帮我写东西，领情了！

lygyjt · 发表于 2021-4-8 12:45

砂海发表于 2021-4-7 22:34
貌似彩票

哈哈，很多人都这么说呢。嗯，权当是这样吧，嘿嘿。

lygyjt · 发表于 2021-4-8 13:20

本帖最后由 lygyjt 于 2021-4-8 13:22 编辑

cutecpu 发表于 2021-4-7 21:49
Sub demo()
bh = Range("b1:h" & Cells(Rows.Count, "b").End(xlUp).Row)
ReDim r(1 To UBound(bh) ...

版主大人，还得来打扰您了。在文件中，如果删除最后一行（增加行，也不行），计算出错了。另外，当数据有01、02..。。。时，计算结果显示1、2..。。。。能不能在结果中，也显示01、02。还请版主大人，在百忙之中再帮改下呗。

cutecpu · 发表于 2021-4-8 13:47

lygyjt 发表于 2021-4-8 13:20
版主大人，还得来打扰您了。在文件中，如果删除最后一行（增加行，也不行），计算出错了。另外，当数据有 ...

您好，要不要上傳會出錯的文件

lygyjt · 发表于 2021-4-8 15:03

cutecpu 发表于 2021-4-8 13:47
您好，要不要上傳會出錯的文件

版主大人，实在不好意思啊，才看到。就在我已经上传的文件中，删除最后一行，就会出现我说的现象了。如果您需要传文件，我现在马上传。

cutecpu · 发表于 2021-4-8 15:33

lygyjt 发表于 2021-4-8 15:03
版主大人，实在不好意思啊，才看到。就在我已经上传的文件中，删除最后一行，就会出现我说的现象了。如果 ...

藍色部份，新增、修改

Sub demo()
bh = Range("b1:h" & Cells(Rows.Count, "b").End(xlUp).Row)
ReDim r(1 To UBound(bh))
ReDim n2r(1 To 99, 1 To UBound(bh))
ReDim c(1 To 99)
For i = 1 To UBound(bh)
   r(i) = 2
   For j = 1 To 7
      n2r(bh(i, j), i) = 1
      c(bh(i, j)) = c(bh(i, j)) + 1
   Next
Next
o = 1
Do While 1
   Max = WorksheetFunction.Max(c)
   If Max <= 1 Then Exit Do
   For i = 1 To 99
      If c(i) = Max Then
         Min = 0
         For j = 1 To UBound(bh)
            If n2r(i, j) Then r(j) = 1: Min = IIf(Min = 0, j, Min)
         Next
         o = o + 1
         Cells(o, "o").Value = Min
         Cells(o, "p").Value = i
      End If
   Next
   For i = 1 To UBound(bh)
      If r(i) = 1 Then
         For j = 1 To 7
            n2r(bh(i, j), i) = 0
            c(bh(i, j)) = c(bh(i, j)) - 1
         Next
         r(i) = 0
      End If
   Next
Loop
If Max = 1 Then
   For i = 1 To UBound(bh)
      If r(i) Then
         o = o + 1
         Cells(o, "o").Value = i
         Cells(o, "p").Resize(1, 7) = Application.Index(bh, i, 0)
      End If
   Next
End If
End Sub

祝順心，南無阿彌陀佛！

lygyjt · 发表于 2021-4-8 15:37

cutecpu 发表于 2021-4-8 15:33
藍色部份，新增、修改

Sub demo()

再次谢谢版主大人的厚爱！

		自动登录	找回密码
密码			注册

[已解决]请教老师：查找最多数

最佳答案

评分

评分

评分

评分