Question

背景：我有一个包含员工ID行和班次列的表（每天两个：上午和下午）。工作人员表明他们是否可以参加每个班次然后我运行一个模块，生成可以参加每个班次的所有ID的列表。

问题：是否有一个模块可以为每个班次获取潜在参与者列表，并为每个AM班次生成四个随机ID，为每个班次班次生成三个随机ID？

PM转换的ID不应与每天的AM转换相同。

图片1：enter link description here

图片2：enter link description here

Answer 1

这样做 - 它对可用员工的数量是灵活的（可以是10，可以是50！）但它确实假设了3件事：

员工列表从第3行开始，此列表中没有空格
周一至周五C列至L列
第一行将指示它是AM还是PM班次

选项明确

Sub Work_timetables()

Dim c As Integer, R As Long, iEmployees As Long, ID As String, iField As Integer, bAM As Boolean, lRandomNumber As Long, iNumbersNeeded As Integer, iPicked As Integer

Application.ScreenUpdating = False

c = 3
R = 2
iField = 1
iEmployees = Range("B3:B" & Range("B3").End(xlDown).Row).Rows.Count

Do Until c > 12
    Range("C2:L" & iEmployees + 2).AutoFilter Field:=iField, Criteria1:="Yes"
    Range("B3:B" & Range("B3").End(xlDown).Row).Copy
    Cells(iEmployees + 4, c).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("C2:L" & iEmployees).AutoFilter
    c = c + 1
    iField = iField + 1
Loop

c = 3
Start:
Do Until c > 12
    If c Mod 2 = 0 Then
        bAM = False
        iNumbersNeeded = 3
    End If
    If Not c Mod 2 = 0 Then
        bAM = True
        iNumbersNeeded = 4
    End If
    If (Cells(1048563, c).End(xlUp).Row - (iEmployees + 3)) < iNumbersNeeded Then
        MsgBox "There isn't enough emplooyees available for the " & Cells(2, c).Value & " (" & Cells(1, c).Value & ") shift" & vbNewLine & vbNewLine & "Moving to next shift", vbOKOnly, "Short staffed!"
        c = c + 1
        GoTo Start
    End If
    Do Until iPicked = iNumbersNeeded
goLoop:
        lRandomNumber = WorksheetFunction.RandBetween(iEmployees + 4, Cells(iEmployees + 4, c).End(xlDown).Row)
        If Trim(Range("B" & lRandomNumber).Value) = "" Then
            Range("B" & lRandomNumber).Value = "Picked"
            Cells(Range("C" & iEmployees + 4).CurrentRegion.Rows.Count + iEmployees + 6 + iPicked, c).Value = Cells(lRandomNumber, c)
            iPicked = iPicked + 1
            Else
                GoTo goLoop
        End If
    Loop
    Range("B" & iEmployees + 4 & ":B" & Range("C" & iEmployees + 4).CurrentRegion.Rows.Count + iEmployees + 4).ClearContents
    c = c + 1
    iPicked = 0
Loop

Application.ScreenUpdating = True

End Sub

创建一个在Excel-VBA 2016中随机化非数字值的模块

1 个答案: