| |
Excelで作っている当番表を改定しようと思っています。
シート１に当番表、シート２に名簿があります。
シート１には、毎週末（土・日）の午前・午後の４つ枠があります。それぞれ当番は４人づつです。
シート２には、名前と当番に入れる時間帯のセルがあり、可能な時間帯に○が記入されています。
シート１の該当箇所に、シート２の名簿の中から条件に合う人をランダムに入力させたいと思っています。
名簿に入っている人数は２００〜３００人ですが、一通り１回づつ回ってから、２順目にいくようにしたいと思っています。
現在作成中のコードは下記のとおりですが、
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
|
|
jeanjean
- 08/9/13(土) 12:19 -
