如何在MS Access中用VBA自动计算合规且总和为100的DLC

需求回顾 #

需生成符合以下条件的DLC数值并写入Access数据表：

• 五类细胞数值范围：
  • Neutrophils（N）：40-80
  • Lymphocytes（L）：20-40
  • Eosinophils（E）：2-8（示例显示为两位格式，存储可保留补零样式）
  • Monocytes（M）：1-3
  • Basophils（B）：0-2
• 五类数值总和必须严格等于100

VBA实现代码 #

Sub GenerateValidDLC()
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim N As Integer, L As Integer, E As Integer, M As Integer, B As Integer
    Dim total As Integer
    Dim adjustAttempts As Integer
    
    ' 初始化数据库和目标数据表（替换为你的表名）
    Set db = CurrentDb
    Set rs = db.OpenRecordset("DLC_Results", dbOpenDynaset)
    
    ' 尝试生成符合条件的数值，最多100次避免死循环
    adjustAttempts = 0
    Do
        ' 第一步：在各细胞范围内生成初始随机值
        N = Int((80 - 40 + 1) * Rnd + 40)
        L = Int((40 - 20 + 1) * Rnd + 20)
        E = Int((8 - 2 + 1) * Rnd + 2)
        M = Int((3 - 1 + 1) * Rnd + 1)
        B = Int((2 - 0 + 1) * Rnd + 0)
        
        total = N + L + E + M + B
        adjustAttempts = adjustAttempts + 1
        
        ' 第二步：调整总和至100，同时保证各值不超出范围
        If total <> 100 Then
            Select Case total
                Case Is > 100
                    ' 总和超量，从有下调空间的细胞依次递减
                    Do While total > 100 And adjustAttempts < 100
                        If N > 40 Then N = N - 1: total = total - 1
                        If total = 100 Then Exit Do
                        If L > 20 Then L = L - 1: total = total - 1
                        If total = 100 Then Exit Do
                        If E > 2 Then E = E - 1: total = total - 1
                        If total = 100 Then Exit Do
                        If M > 1 Then M = M - 1: total = total - 1
                        If total = 100 Then Exit Do
                        If B > 0 Then B = B - 1: total = total - 1
                    Loop
                Case Is < 100
                    ' 总和不足，从有上调空间的细胞依次递增
                    Do While total < 100 And adjustAttempts < 100
                        If N < 80 Then N = N + 1: total = total + 1
                        If total = 100 Then Exit Do
                        If L < 40 Then L = L + 1: total = total + 1
                        If total = 100 Then Exit Do
                        If E < 8 Then E = E + 1: total = total + 1
                        If total = 100 Then Exit Do
                        If M < 3 Then M = M + 1: total = total + 1
                        If total = 100 Then Exit Do
                        If B < 2 Then B = B + 1: total = total + 1
                    Loop
            End Select
        End If
    Loop Until total = 100 Or adjustAttempts >= 100
    
    ' 写入数据表
    If total = 100 Then
        rs.AddNew
        ' 按示例格式存储为两位数字（文本字段用Format，数字字段直接赋值即可）
        rs!Neutrophils = Format(N, "00")
        rs!Lymphocytes = Format(L, "00")
        rs!Eosinophils = Format(E, "00")
        rs!Monocytes = Format(M, "00")
        rs!Basophils = Format(B, "00")
        rs!Total = total
        rs.Update
        MsgBox "DLC数值已保存：N=" & Format(N, "00") & ", L=" & Format(L, "00") & ", E=" & Format(E, "00") & ", M=" & Format(M, "00") & ", B=" & Format(B, "00")
    Else
        MsgBox "尝试次数耗尽，未生成符合条件的数值，请检查范围设定"
    End If
    
    ' 清理资源
    rs.Close
    Set rs = Nothing
    Set db = Nothing
End Sub

使用说明 #

1. 确保数据库中存在数据表DLC_Results，需包含字段：Neutrophils、Lymphocytes、Eosinophils、Monocytes、Basophils（文本/数字类型），以及Total（数字类型）。
2. 若需批量生成多条记录，可在代码外层增加循环，例如：

   Dim i As Integer
   For i = 1 To 10 ' 生成10条有效记录
       GenerateValidDLC
   Next i
   

3. 可根据临床需求调整数值调整的优先级（当前优先调整Neutrophils）。

内容的提问来源于stack exchange，提问作者Viney Kumar