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

lygyjt

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

Sub demo()

版主大人，现在就有一点小问题了：如果原始数据中有01、02之类的，能在结果中，也显示01、02吗？因为现在结果中显示的是1、2；刚刚测试了下，把一楼文件中的前89行全删除后，计算结果中，仍然有小于90的序号存在。（刚才核对了几个结果，是不是您取的工作表的序号？而不是数组的序号？）

cutecpu

lygyjt 发表于 2021-4-8 15:44
版主大人，现在就有一点小问题了：如果原始数据中有01、02之类的，能在结果中，也显示01、02吗？因为现在 ...

您上傳一下附件，我工作忙完後看一下喔！

lygyjt

cutecpu 发表于 2021-4-8 16:09
您上傳一下附件，我工作忙完後看一下喔！

好的，有劳版主大人啦，哈哈

lygyjt

cutecpu 发表于 2021-4-8 16:09
您上傳一下附件，我工作忙完後看一下喔！

让您费心啦！ 查找最多数1.rar (48.32 KB, 下载次数: 1)

2021-4-8 16:23 上传

点击文件名下载附件

lygyjt

cutecpu 发表于 2021-4-8 16:09
您上傳一下附件，我工作忙完後看一下喔！

版主，我先下了啊，晚上一定会来的。

cutecpu

lygyjt 发表于 2021-4-8 16:24
让您费心啦！

藍色，新增、修改部份
P 列用自定義單元格的方式，讓數字固定保持兩位

Sub demo()
   a = Range("a1:a" & Cells(Rows.Count, "a").End(xlUp).Row)
   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, a(j, 1), 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

cutecpu 发表于 2021-4-8 18:10
藍色，新增、修改部份
P 列用自定義單元格的方式，讓數字固定保持兩位

谢谢版主对我的宽容！整天都在麻烦您，为我操了不少心啊。P列要是自定义，转到别的表后，仍然前面缺少0，最好是原样输出，即，文本格式。再有就是，就差一点点就OK了：结果的最后一行，序号是3，它仍然是表的行号，不是数组的序号。还请版主最后再帮着改下啊，行吗？

cutecpu

lygyjt 发表于 2021-4-8 22:24
谢谢版主对我的宽容！整天都在麻烦您，为我操了不少心啊。P列要是自定义，转到别的表后，仍然前面缺少0， ...

藍色部份，新增、修改
P 列格式改成 「文字」

Sub demo()
   a = Range("a1:a" & Cells(Rows.Count, "a").End(xlUp).Row)
   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, a(j, 1), Min)
            Next
            o = o + 1
            Cells(o, "o").Value = Min
            Cells(o, "p").Value = Format(i, "00")
         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 = a(i, 1)
            Cells(o, "p").Resize(1, 7) = Application.Index(bh, i, 0)
         End If
      Next
   End If
End Sub


祝順心，南無阿彌陀佛！

hlw2008

不断学习中

lygyjt

cutecpu 发表于 2021-4-8 22:37
藍色部份，新增、修改
P 列格式改成 「文字」

再次谢谢版主的厚爱！完全正确。这几天让您费心了！