求助一个自动生成学生考级证书编号的代码！通过函数好像没法实现，谢！

zjjEH

月关 发表于 2019-11-29 10:52
我是 "为了农村孩子的全面发展" 才打开附件看看，找了半天愣没找到。。。。难不成是我与互联网隔绝的这俩周 ...

年份后2位+月份2位数+年级班次2位数+第1次过级全校的排名，——假如是第2次编号，不把第1批次过级的人头算进去。因为第1批的已经有了编号。

一把小刀闯天下

zjjEH 发表于 2019-11-29 09:57
对于第一次生成很成功，但第二次考试后再生成证号不能变以前的证号，只对以前未取证且上90分的学生进行编 ...

Option Explicit

Sub test()
  Dim arr, y, m, mark, i, j, cnt
  mark = Split("?,一,二,三,四,五,六,七,八,九", ",")
  arr = Range("a3:m" & Cells(Rows.Count, "b").End(xlUp).Row)
  y = right(Year(Date), 2): m = Format(Month(Date), "00")
  For i = 1 To UBound(arr, 1)
    If Len(arr(i, 10)) Then
      If cnt < Val(right(arr(i, 10), 3)) Then cnt = Val(right(arr(i, 10), 3))
      arr(i, 11) = -1
    Else
      If arr(i, 6) < 90 Then arr(i, 11) = -1 Else arr(i, 11) = arr(i, 6)
    End If
    arr(i, 13) = -i
    arr(i, 12) = Replace(arr(i, 2), "(", vbNullString)
    arr(i, 12) = Replace(arr(i, 12), ")", vbNullString)
    For j = 0 To UBound(mark)
      arr(i, 12) = Replace(arr(i, 12), mark(j), j)
    Next
  Next
  Call bsort(arr, 1, UBound(arr, 1), 1, UBound(arr, 2), 11)
  For i = 1 To UBound(arr, 1)
    If arr(i, 11) = -1 Then Exit For
    cnt = cnt + 1
    arr(i, 10) = y & m & arr(i, 12) & Format(cnt, "000")
  Next
  Call bsort(arr, 1, UBound(arr, 1), 1, UBound(arr, 2), 13)
  [a3].Resize(UBound(arr, 1), UBound(arr, 2) - 3) = arr
End Sub

Function bsort(arr, first, last, left, right, key)
  Dim i, j, k, t
  For i = first To last - 1
    For j = first To last + first - 1 - i
      If arr(j, key) < arr(j + 1, key) Then
        For k = left To right
          t = arr(j, k): arr(j, k) = arr(j + 1, k): arr(j + 1, k) = t
        Next
      End If
    Next
  Next
End Function

zjjEH

让我怎么谢您呢？很完美！但还有一个想法：第二次及以后的名次都从1开始，不接以前的。

一把小刀闯天下

zjjEH 发表于 2019-11-30 12:55
让我怎么谢您呢？很完美！但还有一个想法：第二次及以后的名次都从1开始，不接以前的。

但有个问题，如果是同一天可能有2张证书编号完全一样的（同班），如果这种情况不会发生：

arr(i, 10) = y & m & arr(i, 12) & Format(cnt, "000") 改成

--------------
arr(i, 10) = y & m & arr(i, 12) & Format(i, "000")

月关

躺沙发上习惯性的上来溜达一下，怎么感觉像被算计了。。。。。
xiangbaoan老师这莫名的花给的我有点难堪。。。。
还好大神都解完了，我就偷个懒


Sub test()
Dim arr, brr, score, i&, d As Object, s$, fir$, sec$, thr$, rn As Range
Application.ScreenUpdating = False
With [a2].CurrentRegion
arr = .Value: score = .Resize(, 1).Offset(, 5): brr = .Resize(, 1).Offset(, 9)

For i = 2 To UBound(arr)
If Len(arr(i, 10)) Then Cells(i + 1, 6) = ""
Next

s = "一二三四五六七八九": fir = right(Year(Date), 2)
sec = Format(right(Month(Date), 2), "00"): arr = .Value
Set rn = .Resize(, 1).Offset(, 5): Set d = CreateObject("scripting.dictionary")

For i = 2 To UBound(arr)
thr = InStr(s, left(arr(i, 2), 1)) & Mid(arr(i, 2), 3, 1)
If arr(i, 6) >= 90 Then
d(arr(i, 6)) = d(arr(i, 6)) + 1
brr(i, 1) = fir & sec & thr & Format(Application.Rank(arr(i, 6), rn) + d(arr(i, 6)) - 1, "000")
End If
Next
End With

[f2].Resize(UBound(score)) = score
[j2].Resize(UBound(brr)) = brr
Application.ScreenUpdating = True
End Sub

zjjEH

一把小刀闯天下 发表于 2019-11-30 13:00
但有个问题，如果是同一天可能有2张证书编号完全一样的（同班），如果这种情况不会发生：

arr(i, 10)  ...

大师，为什么一运行代码就把其他单元格的公式全清除了

一把小刀闯天下

zjjEH 发表于 2019-12-1 10:25
大师，为什么一运行代码就把其他单元格的公式全清除了

'15楼的代码试了一下没有覆盖。12楼的修改了一下也可以不覆盖，，，

Option Explicit

Sub test()
  Dim arr, y, m, mark, i, j
  mark = Split("?,一,二,三,四,五,六,七,八,九", ",")
  arr = Range("a3:m" & Cells(Rows.Count, "b").End(xlUp).Row)
  y = right(Year(Date), 2): m = Format(Month(Date), "00")
  For i = 1 To UBound(arr, 1)
    If Len(arr(i, 10)) Then
      arr(i, 11) = -1
    Else
      If arr(i, 6) < 90 Then arr(i, 11) = -1 Else arr(i, 11) = arr(i, 6)
    End If
    arr(i, 1) = arr(i, 10): arr(i, 13) = -i
    arr(i, 12) = Replace(arr(i, 2), "(", vbNullString)
    arr(i, 12) = Replace(arr(i, 12), ")", vbNullString)
    For j = 0 To UBound(mark)
      arr(i, 12) = Replace(arr(i, 12), mark(j), j)
    Next
  Next
  Call bsort(arr, 1, UBound(arr, 1), 1, UBound(arr, 2), 11)
  For i = 1 To UBound(arr, 1)
    If arr(i, 11) = -1 Then Exit For
    arr(i, 1) = y & m & arr(i, 12) & Format(i, "000")
  Next
  Call bsort(arr, 1, UBound(arr, 1), 1, UBound(arr, 2), 13)
  [j3].Resize(UBound(arr, 1)) = arr
End Sub

Function bsort(arr, first, last, left, right, key)
  Dim i, j, k, t
  For i = first To last - 1
    For j = first To last + first - 1 - i
      If arr(j, key) < arr(j + 1, key) Then
        For k = left To right
          t = arr(j, k): arr(j, k) = arr(j + 1, k): arr(j + 1, k) = t
        Next
      End If
    Next
  Next
End Function

zjjEH

一把小刀闯天下 发表于 2019-12-1 12:43
'15楼的代码试了一下没有覆盖。12楼的修改了一下也可以不覆盖，，，

Option Explicit

12、15楼均高手，向您们学习。

月关

zjjEH 发表于 2019-12-2 07:16
12、15楼均高手，向您们学习。

惭愧 ，15楼的代码只是老师布置下作业来不得已而为之，有取巧的意味。当然也有正儿八经的构思过，奈何水平不济也是不得已而为之。
这要上去3个月我搞出来就会欢呼雀跃，搁今天只能苦笑一下。
谢谢楼上老师们的鼓励，我争取以后尽量不那么无耻一些