VBA一次性生成多份体检表

excel玉米

在当前工作表文件路径下生成”体检表“文件夹，将生成的体检表放在该文件夹中。
因有重名（刘婷），故以工号+姓名来命名生成的体检表文件。

chenjun

ykcbf1100 发表于 2024-11-6 16:21
第8项内容有点可怕啊，体检结果居然是取随机值，这么不负责任的吗？

20年前还有在论坛问随机分奖金做账的

xiashuming1

excel玉米 发表于 2024-11-6 20:26
在当前工作表文件路径下生成”体检表“文件夹，将生成的体检表放在该文件夹中。
因有重名（刘婷），故以工 ...

请取消所有日期的取值，简化VBA

Laughingsun889

这案例很有用，能生成独立的个人报表，如表式工资条、体检表、履历表、个人档案等。谢谢写代码的老师，辛苦了！

renkangjizhen

用vba难度不高

excel玉米

xiashuming1 发表于 2024-11-7 14:29
请取消所有日期的取值，简化VBA

自己找到相应的代码块，将其注释掉或者删掉即可。

chengyunpan

参与一下！！！！！！！！

翁知江安

这是测试运行的结果。我只选了前面10个人

翁知江安

Sub zidong()
Dim i, j, k, m, n, irow, s, p, q, t
Dim arr
irow = Sheets("花名册").[a65536].End(xlUp).Row
arr = Sheets("花名册1").Range("a1:m" & irow)
For i = 2 To irow
    Sheets("体检表").Cells(13, 5) = arr(i, 3)
    Sheets("体检表").Cells(15, 5) = arr(i, 4)
    Sheets("体检表").Cells(17, 5) = arr(i, 5)
    Sheets("体检表").Cells(19, 5) = arr(i, 11)
    Sheets("体检表").Cells(23, 5) = arr(i, 12)
    Sheets("体检表").Cells(28, 5) = arr(i, 13)
    j = j + 202406220021#
    Sheets("体检表").Cells(53, 3) = j
    For k = 56 To 57
      m = Split(Sheets("体检表").Cells(k, 8), "-")(0)
      n = Split(Sheets("体检表").Cells(k, 8), "-")(1)
      s = Application.WorksheetFunction.RandBetween(m, n)
      Sheets("体检表").Cells(k, 3) = s
    Next

    For k = 89 To 96
    m = Split(Sheets("体检表").Cells(k, 8), "-")(0)
    n = Split(Sheets("体检表").Cells(k, 8), "-")(1)
    If Val(m) = Int(m) And Val(n) = Int(n) Then
      s = Application.WorksheetFunction.RandBetween(m, n)
       Sheets("体检表").Cells(k, 3) = s
      Else
       p = Len(m) - InStr(m, ".")
       q = Len(n) - InStr(n, ".")
       t = Application.WorksheetFunction.Max(p, q)
       s = Application.WorksheetFunction.RandBetween(m * 10 ^ t, n * 10 ^ t)
       Sheets("体检表").Cells(k, 3) = s / 10 ^ t
       End If
    Next
    For k = 211 To 255
     If Sheets("体检表").Cells(k, 8) <> "" And Sheets("体检表").Cells(k, 9) = "" Then
     m = Split(Sheets("体检表").Cells(k, 8), "-")(0)
     n = Split(Sheets("体检表").Cells(k, 8), "-")(1)
      If Val(m) = Int(m) And Val(n) = Int(n) Then
       s = Application.WorksheetFunction.RandBetween(m, n)
       Sheets("体检表").Cells(k, 3) = s
       Else
        p = Len(m) - InStr(m, ".")
        q = Len(n) - InStr(n, ".")
        t = Application.WorksheetFunction.Max(p, q)
        s = Application.WorksheetFunction.RandBetween(m * 10 ^ t, n * 10 ^ t)
        Sheets("体检表").Cells(k, 3) = s / 10 ^ t
       End If
     End If
    Next
    Sheets("体检表").Copy
   ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & arr(i, 3) & "体检表" & ".xlsx"
   ActiveWorkbook.Close True
Next
End Sub

翁知江安

仅供参考，欢迎批评指正