|
Excelで作っている当番表を改定しようと思っています。
シート1に当番表、シート2に名簿があります。
シート1には、毎週末(土・日)の午前・午後の4つ枠があります。それぞれ当番は4人づつです。
シート2には、名前と当番に入れる時間帯のセルがあり、可能な時間帯に○が記入されています。
シート1の該当箇所に、シート2の名簿の中から条件に合う人をランダムに入力させたいと思っています。
名簿に入っている人数は200〜300人ですが、一通り1回づつ回ってから、2順目にいくようにしたいと思っています。
現在作成中のコードは下記のとおりですが、
ReDim Preserve のところの、
strOkMember(lngOkCount) = rngTimeColumn.Offset(j, (i + 1) * (-1)).Value
がエラーになってしまいます。
初心者なもので、なぜエラーになるのかわかりません。
説明が下手でわかりにくいと思いますが、
どうかご教示いただけますでしょうか?よろしくお願いいたしますm(__)m
''////////////////////////////////////////////////////////////
Sub PickUpTest()
Const SHEET_ONE As String = "当番表"
Const SHEET_TWO As String = "名簿"
Const FIELD_B As Integer = 2
Const FIELD_C As Integer = 3
Const INTER_CHAR As String = "・" '
Const OK_VALUE As String = "○"
Const TIME_BOX As Integer = 3
Const SELECT_MEMBER As Integer = 4
Dim strTimeArray(TIME_BOX) As String
Dim i As Long, j As Long
Randomize
For i = 0 To TIME_BOX
With Worksheets(SHEET_ONE)
strTimeArray(i) = _
.Cells(i + 1, FIELD_B) & INTER_CHAR & .Cells(i + 1, FIELD_C)
End With
Next
With Worksheets(SHEET_TWO)
Dim lngCheckRows As Long
lngCheckRows = .UsedRange.Rows.Count - 1
For i = 0 To TIME_BOX
Dim rngTimeColumn As Range
Dim strFirstFind As String
Dim strOkMember() As String
Dim lngOkCount As Long
Dim strSelectMember(SELECT_MEMBER - 1) As String
Dim lngUsedNumber(SELECT_MEMBER - 1) As Long
Dim lngRandNum As Long
Dim lngSelectCount As Long
Dim lngUsedCheck As Long
Set rngTimeColumn = _
.Range("1:1").Find(what:=strTimeArray(i), lookat:=xlWhole)
If Not rngTimeColumn Is Nothing Then
strFirstFind = rngTimeColumn.Address
lngOkCount = 0
For j = 1 To lngCheckRows
If rngTimeColumn.Offset(j, 0).Value = OK_VALUE Then
ReDim Preserve strOkMember(lngOkCount)
strOkMember(lngOkCount) = rngTimeColumn.Offset(j, (i + 1) * (-1)).Value
lngOkCount = lngOkCount + 1
End If
Next
If lngOkCount = 0 Then
ReDim strOkMember(0)
strOkMember(0) = "【みんなダメ!】"
End If
If UBound(strOkMember) < SELECT_MEMBER Then
For j = 0 To UBound(strOkMember)
Worksheets(SHEET_ONE).Cells(i + 1, FIELD_C + j + 1) = strOkMember(j)
Next
Else
lngSelectCount = 0
Do
lngRandNum = CLng(Int(Rnd() * lngOkCount))
If lngSelectCount = 0 Then
strSelectMember(lngSelectCount) = strOkMember(lngRandNum)
lngUsedNumber(lngSelectCount) = lngRandNum
lngSelectCount = 1
Else
lngUsedCheck = 1
For j = 0 To UBound(lngUsedNumber)
lngUsedCheck = lngUsedCheck * (lngRandNum - lngUsedNumber(j))
Next
If lngUsedCheck <> 0 Then
strSelectMember(lngSelectCount) = strOkMember(lngRandNum)
lngUsedNumber(lngSelectCount) = lngRandNum
lngSelectCount = lngSelectCount + 1
End If
End If
Loop Until lngSelectCount = SELECT_MEMBER
For j = 0 To UBound(strSelectMember)
Worksheets(SHEET_ONE).Cells(i + 1, FIELD_C + j + 1) = strSelectMember(j)
Next
End If
End If
Next
End With
End Sub
|
|