Rotating employees and where to working

[coliervile]

Good day to everyone-
I'm trying to come up with a schedule where all of our trainees work with each other and train in the labs on the three position. I currently use a very basic lab rotation in which the trainees work with the same group all of the time. I would like the trainees to work with all of the trainees to see how the other trainees do things (the first table at the top of the image). The trainees must train on the one of the three positions (LC, GC, and MO) over three hours in one of our three labs. Is there a way to randomly assign the trainees (in the second table in the example). The second table assignments was taken from a sudoku generator, but it does not meet our requirements of the students working one of the three positions each hour. In the second example trainee number 1 works MO position twice and the GC position once in a three hour period. What I would like is what trainee 4 worked; GC, LC, and MO over a three hour period. It does not matter what order the positions are worked in or what lab they work in.

Is this possible with excel either via a formula or a VBA code?

Thanks,
Charlie




Run 1
Run 2
Run 3
Run 4
Run 5
Run 6
Run 7
Run 8
Run 9


1
7LC
9MO
9GC
9LC
8MO
8GC
8LC
LMO
7GC


2
7GC
7LC
9MO
9GC
9LC
8MO
8GC
8LC
LMO


3
7MO
7GC
7LC
9MO
9GC
9LC
8MO
8GC
8LC


4
8LC
7MO
7GC
7LC
9MO
9GC
9LC
8MO
8GC


5
8GC
8LC
7MO
7GC
7LC
9MO
9GC
9LC
8MO


6
8MO
8GC
8LC
7MO
7GC
7LC
9MO
9GC
9LC


7
9LC
8MO
8GC
8LC
7MO
7GC
7LC
9MO
9GC


8
9GC
9LC
8MO
8GC
8LC
7MO
7GC
7LC
9MO


9
9MO
9GC
9LC
8MO
8GC
8LC
7MO
7GC
7LC







































Run 1
Run 2
Run 3
Run 4
Run 5
Run 6
Run 7
Run 8
Run 9


7LC
3



4



7
6
5
1
9
2
8


7GC
6
8
5
9
2
3
4
1
7


7MO



9



2
1
7
4
8
5
6
3


8LC
2
5
3
8
9
7
6
4
1


8GC
1
7



9



3
6
4
8
5
2


8MO
8
6
4
5
1
2
7
3
9


9LC
7
9
2
4
3
5
1
8
6


9GC
4
3
6
1
8
9
2
7
5


9MO
5
1
8
2
7
6
3
9
4

[coliervile]

Has anyone come up with an idea for solving my dilemma?

Thanks
Charlie

[SamT]

You wrote of 3 hours and three labs, but neither of those are identified in your tables.

We have to assume the the numbers in the first column of the first table are student numbers. Is the student count (9) a fixed number? If not, what are the upper and lower limits?

You wrote of three positions, but your table has 9; two Type 7's, three types 8 and 9 and one type L. All types are not present for all students

What are Run numbers and their significance to the code solution?

[coliervile]

Sam T thank you for looking at this.The Run's (sorry no pun intended) Run 1, Run 2 and so on are hour hour sessions in the Lab. The Lab's and the position the trainee is being trained on are identified by; 7LC for Lab 7 on Local Control, 8GC for Lab 8 on Ground Control, and 9MO for Lab 9 on Monitor. Each trainee must train on one of the three position, Local Control, Ground Control, and Monitor every three hours. The trainees does not have to train on any given position just as long as they don't train on back to back positions (e.g. they can't train on LC two times in a row) or in a specific Lab in the three hours just as long as they fulfill the overall requirement. The student ID numbers are 1-9.
The first example is what we are using now and the second one is one that I came up with.
You can use one of my examples or whatever design you might come up with to make it work.


Thanks again,
Charlie

[SamT]

7, 8, & 9 are labs.
LC, GC, & MO are positions.

Where n and m are labs and n can be the same lab in all three positions.
In three consecutive hours, they can train on nLC, nGC, & nMO.
In three consecutive hours, they can train on nLC, nGC, & nLC, but that is not preferred.
In any 2 consecutive hours, they can not train on nLC and mLC.

[coliervile]

Hello everyone-
Boy, I hope that I can make sense explaining this in writing! I'm currently rotating student through different work groups manually and would like to know if there is an easier way of doing this using formulas or a macro.

1. In Rotation 1 I fill-in the names of in the range A1:A18.

2. In column A there are three Workgroups 1 through 3; Group 1 rows 1 through 6, Group 2 rows 7 through 12 and Group 3 rows 13 through 18

3. To make up Rotation 2, Column B- I first take the names in the range A7:A18 (Group 2 and Group 3 from column A) to make up the range in B1:B6 (Group 1 in column B). I do this by using a RAND and RANK putting the Ranks 1 through 6 in B1:B6

4. The names that aren't used in B1:B6 must go into the range B7:B18 (Group 2 and Groups 3 in column B). If the names came out of the range A6:A12 (Group 2 column A) they can only be used in the range of B13:B18 (Group 3 column B) and if the names come out of A13:A18 (Group 3 column A) they can only be used in the range of B7:B12 (Column B).

5. I then take the names in range A1:A6 and RAND and RANK them and fill in the first empty cell in the range of B7:B18, starting with the number 1.

6. In rotation 3 I take the names from B1:B6 and place them in Group 2 and Group 3 column C range C7:C18. If the name came out of column A Group 2 initially it will be placed in Group 3 in column C range C13:C18 since they have been used in Group 1 and Group 2 already. If the name came out of Group 3 initially it will be placed in column C range C7:C12 since they were used already in Group 1 and Group 3.

7. I then take the names from the range of C7:C12 Group 2 and place them in either Group 1 or Group 3 column C. If the names initially came out column A Group 3 they will be placed in column C Group 1 since they have been used in Group 2 and Group 3. If the names initially came from column A Group 1 they will be place in column C Group 3 since they have been used in Group 1 and Group 2.

8. I then take the names from column B range B13:B18 and place them in Group 1 or Group 2 column C. If the names initially came out of Group 2 in column A they will be place in Group 1 C1:C6 since they have been used in Group 2 and Group 3. If the names initially came out of Group 1 in in column A they will be place in Group 2 C7:C12 since they have been used in Group 1 and Group 3.

9. To make up Rotation 4 I repeat numbers 3, 4, and 5 using the information in the range of C1:C18 column C.
See example below and thanks for looking.



Scott
Tom
Karen
Zachary
Group 1


Alexandra
Jeremiah
Thomas
Jeremiah


Joshua
Eric
Andrew
Joshua


Rafael
Randall
Jason
Rafael


David
Michael
Roderick
Scott


Zachary
Shaun
Johann
Michael


Johann
Karen
Tom
David
Group 2


Andrew
Thomas
Randall
Eric


Eric
David
Michael
Thomas


Jason
Scott
Shaun
Andrew


Jeremiah
Rafael
Alexandra
Johann


Roderick
Joshua
Zachary
Jason


Michael
Andrew
Jeremiah
Shaun
Group 3


Karen
Jason
Eric
Tom


Thomas
Roderick
David
Alexandra


Shaun
Johann
Scott
Randall


Randall
Alexandra
Rafael
Roderick


Tom
Zachary
Joshua
Karen


Rotation 1
Rotation 2
Rotation 3
Rotation 4

[Aussiebear]

is there any significance in the 10, 7, 7 breakdown per group?

[coliervile]

Thanks Aussiebear for looking at my question. In my post #6 a name can only be in one group in each rotation. If a name has been used in Rotation 1&2 in Group 2 (rows 7-12) in Rotation 1 and Group 1 (rows 1-6) in Rotation 2 it can only be used in Group 3 (rows 13-18) in Rotation 3.

[vert]

I think this might accomplish what your after. I didn't try it for anything past the 18 student example though.

edit: Found an issue with the shuffle. It will sometimes fill all of a group in Rotation 2 or Rotation 4. The shuffle will reshuffle the row numbers if this occurs.


Sub ShuffleArrayInPlace(InArray As Variant)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''
' ShuffleArrayInPlace
' This shuffles InArray to random order, randomized in place.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''
Dim N As Long
Dim Temp As Variant
Dim J As Long
R = 3
If UBound(InArray) >= 2 Then
Randomize
For N = LBound(InArray) To UBound(InArray) - 1
J = N
Do Until N <> J
J = CLng(((UBound(InArray) - 1) - LBound(InArray)) * Rnd + LBound(InArray))
Loop
If N <> J Then
Temp = InArray(N)
InArray(N) = InArray(J)
InArray(J) = Temp
End If
Next N
End If

If UBound(InArray) = 12 And IsNumeric(InArray(0)) Then
If InArray(0) > 6 And InArray(0) < 13 Then
For N = LBound(InArray) To 4
If InArray(N) > 12 Then
Exit For
End If
Next N
If N = 5 Then
GoTo ReShuffle
End If
Else
For N = LBound(InArray) To 4
If InArray(N) < 13 Then
Exit For
End If
Next N
If N = 5 Then
GoTo ReShuffle
End If
End If
End If
End Sub
Sub Rotation()
Dim Rng As Range
Dim R2G1 As Range, R2G2 As Range, R2G3 As Range, R2D1 As Range, R2D2 As Range, R2D3 As Range, R2D4 As Range
Dim R3G1 As Range, R3G2 As Range, R3G3 As Range, R3D1 As Range, R3D2 As Range, R3D3 As Range
Dim R4G1 As Range, R4G2 As Range, R4G3 As Range, R4D1 As Range, R4D2 As Range, R4D3 As Range, R4D4 As Range
With ActiveWorkbook.Worksheets(1)
Set Rng = .Range("B1:D18") ' Rotation 2 - 4

Set R2G1 = .Range("A1:A6") ' Rotation 2 Group 1
Set R2G2 = .Range("A7:A12") ' Rotation 2 Group 2
Set R2G3 = .Range("A13:A18") ' Rotation 2 Group 3
Set R2D1 = .Range("B7:B18") ' Rotation 2 Destination 1
Set R2D2 = .Range("B13:B18") ' Rotation 2 Destination 2
Set R2D3 = .Range("B1:B6") ' Rotation 2 Destination 3
Set R2D4 = .Range("B1:B12") ' Rotation 2 Destination 3

Set R3G1 = .Range("B1:B6") ' Rotation 3 Group 1
Set R3G2 = .Range("B7:B12") ' Rotation 3 Group 2
Set R3G3 = .Range("B13:B18") ' Rotation 3 Group 3
Set R3D1 = .Range("C1:C6") ' Rotation 3 Destination 1
Set R3D2 = .Range("C7:C12") ' Rotation 3 Destination 2
Set R3D3 = .Range("C13:C18") ' Rotation 3 Destination 3

Set R4G1 = .Range("C1:C6") ' Rotation 4 Group 1
Set R4G2 = .Range("C7:C12") ' Rotation 4 Group 2
Set R4G3 = .Range("C13:C18") ' Rotation 4 Group 3
Set R4D1 = .Range("D7:D18") ' Rotation 4 Destination 1
Set R4D2 = .Range("D13:D18") ' Rotation 4 Destination 2
Set R4D3 = .Range("D1:D6") ' Rotation 4 Destination 3
Set R4D4 = .Range("D1:D12") ' Rotation 4 Destination 3

Rng.ClearContents

Call Rotation2(R2G1, R2G2, R2G3, R2D1, R2D2, R2D3, R2D4)
Call Rotation3(R3G1, R3G2, R3G3, R3D1, R3D2, R3D3)
Call Rotation4(R4G1, R4G2, R4G3, R4D1, R4D2, R4D3, R4D4)

'uncomment to removed rotation numbers from range
'For Each i In Rng
' S = Split(i.Value, " ")
' i.Value = S(0)
'Next i

End With
End Sub

Sub Rotation2(R2Grp1 As Range, R2Grp2 As Range, R2Grp3 As Range, R2Dest1 As Range, R2Dest2 As Range, R2Dest3 As Range, R2Dest4 As Range)
Dim J, M As Integer
Dim Group(), Destination() As Variant

With ActiveWorkbook.Worksheets(1)
'****R2G1

J = 1 'Array size
M = 0 'Array index
For Each i In R2Grp1
ReDim Preserve Group(J)
Group(M) = i.Value & " 1"
J = J + 1
M = M + 1
Next i

J = 1 'Array size
M = 0 'Array index
For Each i In R2Dest1
ReDim Preserve Destination(J)
Destination(M) = i.Row
J = J + 1
M = M + 1
Next i

Call ShuffleArrayInPlace(Group)
Call ShuffleArrayInPlace(Destination)

For i = 0 To UBound(Group) - 1
.Range("B" & Destination(i)).Value = Group(i)
Next i

'**********
'****R2G2

R = 7
J = 1 'Array size
M = 0 'Array index
Erase Group
For Each i In R2Grp2
ReDim Preserve Group(J)
Group(M) = i.Value & " 2"
J = J + 1
M = M + 1
R = R + 1
Next i

J = 1 'Array size
M = 0 'Array index
Erase Destination
For Each i In R2Dest2
If i.Value = "" Then
ReDim Preserve Destination(J)
Destination(M) = i.Row
J = J + 1
M = M + 1
End If
Next i

Call ShuffleArrayInPlace(Group)
Call ShuffleArrayInPlace(Destination)

For i = 0 To UBound(Destination) - 1
.Range("B" & Destination(i)).Value = Group(i)
Next i

D = UBound(Destination)

J = 1 'Array size
M = 0 'Array index
Erase Destination
For Each i In R2Dest3
If i.Value = "" Then
ReDim Preserve Destination(J)
Destination(M) = i.Row
J = J + 1
M = M + 1
End If
Next i

Call ShuffleArrayInPlace(Destination)

For i = D To UBound(Group) - 1
.Range("B" & Destination(i)).Value = Group(i)
Next i
'********
'****R2G3

J = 1 'Array size
M = 0 'Array index
Erase Group
For Each i In R2Grp3
ReDim Preserve Group(J)
Group(M) = i.Value & " 3"
J = J + 1
M = M + 1
Next i

J = 1 'Array size
M = 0 'Array index
Erase Destination
For Each i In R2Dest4
If i.Value = "" Then
ReDim Preserve Destination(J)
Destination(M) = i.Row
J = J + 1
M = M + 1
End If
Next i

Call ShuffleArrayInPlace(Group)
Call ShuffleArrayInPlace(Destination)

For i = 0 To UBound(Group) - 1
.Range("B" & Destination(i)).Value = Group(i)
Next i
End With
End Sub
Sub Rotation3(R3Grp1 As Range, R3Grp2 As Range, R3Grp3 As Range, R3Dest1 As Range, R3Dest2 As Range, R3Dest3 As Range)

Dim J, M, GR1s, GR1i, GR2s, GR2i, GR3s, GR3i As Integer
Dim Group1(), Group2(), Group3(), Sorting()

With ActiveWorkbook.Worksheets(1)

J = 1 'Array size
M = 0 'Array index
For Each i In R3Grp1
ReDim Preserve Sorting(J)
Sorting(M) = i.Value & " 1"
J = J + 1
M = M + 1
Next i
For Each i In R3Grp2
ReDim Preserve Sorting(J)
Sorting(M) = i.Value & " 2"
J = J + 1
M = M + 1
Next i
For Each i In R3Grp3
ReDim Preserve Sorting(J)
Sorting(M) = i.Value & " 3"
J = J + 1
M = M + 1
Next i

GR1s = 1 'Group1 Array size
GR1i = 0 'Group1 Array index
GR2s = 1 'Group2 Array size
GR2i = 0 'Group2 Array index
GR3s = 1 'Group2 Array size
GR3i = 0 'Group2 Array index
Erase Group1
Erase Group2
Erase Group3
For i = 0 To UBound(Sorting) - 1
S = Split(Sorting(i), " ")
If CInt(S(1)) + CInt(S(2)) = 3 Then
ReDim Preserve Group3(GR3s)
Group3(GR3i) = Sorting(i)
GR3s = GR3s + 1
GR3i = GR3i + 1
ElseIf CInt(S(1)) + CInt(S(2)) = 4 Then
ReDim Preserve Group2(GR2s)
Group2(GR2i) = Sorting(i)
GR2s = GR2s + 1
GR2i = GR2i + 1
ElseIf CInt(S(1)) + CInt(S(2)) = 5 Then
ReDim Preserve Group1(GR1s)
Group1(GR1i) = Sorting(i)
GR1s = GR1s + 1
GR1i = GR1i + 1
End If
Next i
For i = 0 To UBound(Group1) - 1
R3Dest1(i + 1).Value = Group1(i)
Next i
For i = 0 To UBound(Group2) - 1
R3Dest2(i + 1).Value = Group2(i)
Next i
For i = 0 To UBound(Group3) - 1
R3Dest3(i + 1).Value = Group3(i)
Next i
End With
End Sub
Sub Rotation4(R4Grp1 As Range, R4Grp2 As Range, R4Grp3 As Range, R4Dest1 As Range, R4Dest2 As Range, R4Dest3 As Range, R4Dest4 As Range)

Dim J, M As Integer
Dim Group(), Destination() As Variant

With ActiveWorkbook.Worksheets(1)
'****R2G1

J = 1 'Array size
M = 0 'Array index
For Each i In R4Grp1
ReDim Preserve Group(J)
Group(M) = i.Value & " 1"
J = J + 1
M = M + 1
Next i

J = 1 'Array size
M = 0 'Array index
For Each i In R4Dest1
ReDim Preserve Destination(J)
Destination(M) = i.Row
J = J + 1
M = M + 1
Next i
Call ShuffleArrayInPlace(Group)
Call ShuffleArrayInPlace(Destination)

For i = 0 To UBound(Group) - 1
.Range("D" & Destination(i)).Value = Group(i)
Next i
'**********
'****R2G2

R = 7
J = 1 'Array size
M = 0 'Array index
Erase Group
For Each i In R4Grp2
ReDim Preserve Group(J)
Group(M) = i.Value & " 2"
J = J + 1
M = M + 1
R = R + 1
Next i

J = 1 'Array size
M = 0 'Array index
Erase Destination
For Each i In R4Dest2
If i.Value = "" Then
ReDim Preserve Destination(J)
Destination(M) = i.Row
J = J + 1
M = M + 1
End If
Next i

Call ShuffleArrayInPlace(Group)
Call ShuffleArrayInPlace(Destination)
For i = 0 To UBound(Destination) - 1
.Range("D" & Destination(i)).Value = Group(i)
Next i

D = UBound(Destination)

J = 1 'Array size
M = 0 'Array index
Erase Destination
For Each i In R4Dest3
If i.Value = "" Then
ReDim Preserve Destination(J)
Destination(M) = i.Row
J = J + 1
M = M + 1
End If
Next i

Call ShuffleArrayInPlace(Destination)

For i = D To UBound(Group) - 1
.Range("D" & Destination(i)).Value = Group(i)
Next i
'********
'****R2G3

J = 1 'Array size
M = 0 'Array index
Erase Group
For Each i In R4Grp3
ReDim Preserve Group(J)
Group(M) = i.Value & " 3"
J = J + 1
M = M + 1
Next i

J = 1 'Array size
M = 0 'Array index
Erase Destination
For Each i In R4Dest4
If i.Value = "" Then
ReDim Preserve Destination(J)
Destination(M) = i.Row
J = J + 1
M = M + 1
End If
Next i

Call ShuffleArrayInPlace(Group)
Call ShuffleArrayInPlace(Destination)

For i = 0 To UBound(Group) - 1
.Range("D" & Destination(i)).Value = Group(i)
Next i
End With
End Sub

[coliervile]

Vert thanks for looking into my question and your macro. I can't run it until I return to work on Tuesday. I will get you feed back and let you know.

Best regards,
Charlie

[coliervile]

Good day Vert

I ran your code and no matter what macro I run I get Compile error: Label not defined in ShuffleArrayInPlace macro at this part of the macro "GoTo ReShuffle"

Charlie

[vert]

That is so odd that the label didn't paste over. Here it is with the ReShuffle: label.


Sub ShuffleArrayInPlace(InArray As Variant)
Dim N As Long
Dim Temp As Variant
Dim J As Long
R = 3
ReShuffle:
If UBound(InArray) >= 2 Then
Randomize
For N = LBound(InArray) To UBound(InArray) - 1
J = N
Do Until N <> J
J = CLng(((UBound(InArray) - 1) - LBound(InArray)) * Rnd + LBound(InArray))
Loop
If N <> J Then
Temp = InArray(N)
InArray(N) = InArray(J)
InArray(J) = Temp
End If
Next N
End If

If UBound(InArray) = 12 And IsNumeric(InArray(0)) Then
If InArray(0) > 6 And InArray(0) < 13 Then
For N = LBound(InArray) To 4
If InArray(N) > 12 Then
Exit For
End If
Next N
If N = 5 Then
GoTo ReShuffle
End If
Else
For N = LBound(InArray) To 4
If InArray(N) < 13 Then
Exit For
End If
Next N
If N = 5 Then
GoTo ReShuffle
End If
End If
End If
End Sub

[coliervile]

Vert thanks for the new macro. Does the "ShuffleArrayInPlace" shuffle the names in Column A in the range of A1:A18?

Charlie

[vert]

No, it shuffles each group and destination. Group 1 Rotation 1, it shuffles group 1 (A1:A6) and shuffles its destination (B7:B18) etc. When a name is moved to a group a number is inserted next to their name to show what groups they have been in. When they are to be shuffled and placed again we know where they have been and where not to put them. I left the numbers on the names so you could see and verify where they have been. If you uncomment the few lines at the end of the ShuffleArrayInPlace it will remove the numbers.

mike

[coliervile]

Thank you Mike ("vert") for the clarification. everything worked great. Which lines exactly would I remove?

Thanks again for you help,

[coliervile]

Thanks Mike I see where I need to uncomment.

Charlie

[vert]

Charlie, just thought of something. I didn't take into account for a last name. The function to look where the name has been splits the name using a space as the delimiter. If you need a last name or initial don't put a space after the first name. If you need to have the space between a last and first name I can see about working that into it.

mike

[coliervile]

Thanks Mike for the information and all of your help.

[coliervile]

Hello everyone,

The coding in this Thread was provided by "Vert" (Mike) and it does everything that I want it to do and was setup for 18 employees. I need to modify the coding for 9, 12, and 15 employees I've tried to adjust the coding, but without success. Can any one point out where I need to adjust this coding to make it work for 9, 12, 15 employees. For 9 employees thier names are placed in A1:A9, for 12 employees their names are placed in A1:A12, and for 15 employees their names are placed in A1:A15 all are in different workbooks and the sheet references reamin the same as in the original codings. :bug:

Sub ShuffleArrayInPlace(InArray As Variant)
Dim N As Long
Dim Temp As Variant
Dim J As Long
R = 3
ReShuffle:
If UBound(InArray) >= 2 Then
Randomize
For N = LBound(InArray) To UBound(InArray) - 1
J = N
Do Until N <> J
J = CLng(((UBound(InArray) - 1) - LBound(InArray)) * Rnd + LBound(InArray))
Loop
If N <> J Then
Temp = InArray(N)
InArray(N) = InArray(J)
InArray(J) = Temp
End If
Next N
End If

If UBound(InArray) = 12 And IsNumeric(InArray(0)) Then
If InArray(0) > 6 And InArray(0) < 13 Then
For N = LBound(InArray) To 4
If InArray(N) > 12 Then
Exit For
End If
Next N
If N = 5 Then
GoTo ReShuffle
End If
Else
For N = LBound(InArray) To 4
If InArray(N) < 13 Then
Exit For
End If
Next N
If N = 5 Then
GoTo ReShuffle
End If
End If
End If
End Sub

Sub Rotation()
Dim Rng As Range
Dim R2G1 As Range, R2G2 As Range, R2G3 As Range, R2D1 As Range, R2D2 As Range, R2D3 As Range, R2D4 As Range
Dim R3G1 As Range, R3G2 As Range, R3G3 As Range, R3D1 As Range, R3D2 As Range, R3D3 As Range
Dim R4G1 As Range, R4G2 As Range, R4G3 As Range, R4D1 As Range, R4D2 As Range, R4D3 As Range, R4D4 As Range
With ActiveWorkbook.Worksheets(1)
Set Rng = .Range("B1:D18") ' Rotation 2 - 4
Set R2G1 = .Range("A1:A6") ' Rotation 2 Group 1
Set R2G2 = .Range("A7:A12") ' Rotation 2 Group 2
Set R2G3 = .Range("A13:A18") ' Rotation 2 Group 3
Set R2D1 = .Range("B7:B18") ' Rotation 2 Destination 1
Set R2D2 = .Range("B13:B18") ' Rotation 2 Destination 2
Set R2D3 = .Range("B1:B6") ' Rotation 2 Destination 3
Set R2D4 = .Range("B1:B12") ' Rotation 2 Destination 3
Set R3G1 = .Range("B1:B6") ' Rotation 3 Group 1
Set R3G2 = .Range("B7:B12") ' Rotation 3 Group 2
Set R3G3 = .Range("B13:B18") ' Rotation 3 Group 3
Set R3D1 = .Range("C1:C6") ' Rotation 3 Destination 1
Set R3D2 = .Range("C7:C12") ' Rotation 3 Destination 2
Set R3D3 = .Range("C13:C18") ' Rotation 3 Destination 3
Set R4G1 = .Range("C1:C6") ' Rotation 4 Group 1
Set R4G2 = .Range("C7:C12") ' Rotation 4 Group 2
Set R4G3 = .Range("C13:C18") ' Rotation 4 Group 3
Set R4D1 = .Range("D7:D18") ' Rotation 4 Destination 1
Set R4D2 = .Range("D13:D18") ' Rotation 4 Destination 2
Set R4D3 = .Range("D1:D6") ' Rotation 4 Destination 3
Set R4D4 = .Range("D1:D12") ' Rotation 4 Destination 3
Rng.ClearContents
Call Rotation2(R2G1, R2G2, R2G3, R2D1, R2D2, R2D3, R2D4)
Call Rotation3(R3G1, R3G2, R3G3, R3D1, R3D2, R3D3)
Call Rotation4(R4G1, R4G2, R4G3, R4D1, R4D2, R4D3, R4D4)
'uncomment to removed rotation numbers from range
For Each i In Rng
S = Split(i.Value, " ")
i.Value = S(0)
Next i
End With
End Sub

Sub Rotation2(R2Grp1 As Range, R2Grp2 As Range, R2Grp3 As Range, R2Dest1 As Range, R2Dest2 As Range, R2Dest3 As Range, R2Dest4 As Range)
Dim J, M As Integer
Dim Group(), Destination() As Variant
With ActiveWorkbook.Worksheets(1)
'****R2G1
J = 1 'Array size
M = 0 'Array index
For Each i In R2Grp1
ReDim Preserve Group(J)
Group(M) = i.Value & " 1"
J = J + 1
M = M + 1
Next i
J = 1 'Array size
M = 0 'Array index
For Each i In R2Dest1
ReDim Preserve Destination(J)
Destination(M) = i.Row
J = J + 1
M = M + 1
Next i
Call ShuffleArrayInPlace(Group)
Call ShuffleArrayInPlace(Destination)
For i = 0 To UBound(Group) - 1
.Range("B" & Destination(i)).Value = Group(i)
Next i
'****R2G2
R = 7
J = 1 'Array size
M = 0 'Array index
Erase Group
For Each i In R2Grp2
ReDim Preserve Group(J)
Group(M) = i.Value & " 2"
J = J + 1
M = M + 1
R = R + 1
Next i
J = 1 'Array size
M = 0 'Array index
Erase Destination
For Each i In R2Dest2
If i.Value = "" Then
ReDim Preserve Destination(J)
Destination(M) = i.Row
J = J + 1
M = M + 1
End If
Next i
Call ShuffleArrayInPlace(Group)
Call ShuffleArrayInPlace(Destination)
For i = 0 To UBound(Destination) - 1
.Range("B" & Destination(i)).Value = Group(i)
Next i
D = UBound(Destination)
J = 1 'Array size
M = 0 'Array index
Erase Destination
For Each i In R2Dest3
If i.Value = "" Then
ReDim Preserve Destination(J)
Destination(M) = i.Row
J = J + 1
M = M + 1
End If
Next i
Call ShuffleArrayInPlace(Destination)
For i = D To UBound(Group) - 1
.Range("B" & Destination(i)).Value = Group(i)
Next i
'****R2G3
J = 1 'Array size
M = 0 'Array index
Erase Group
For Each i In R2Grp3
ReDim Preserve Group(J)
Group(M) = i.Value & " 3"
J = J + 1
M = M + 1
Next i
J = 1 'Array size
M = 0 'Array index
Erase Destination
For Each i In R2Dest4
If i.Value = "" Then
ReDim Preserve Destination(J)
Destination(M) = i.Row
J = J + 1
M = M + 1
End If
Next i
Call ShuffleArrayInPlace(Group)
Call ShuffleArrayInPlace(Destination)
For i = 0 To UBound(Group) - 1
.Range("B" & Destination(i)).Value = Group(i)
Next i
End With
End Sub

Sub Rotation3(R3Grp1 As Range, R3Grp2 As Range, R3Grp3 As Range, R3Dest1 As Range, R3Dest2 As Range, R3Dest3 As Range)
Dim J, M, GR1s, GR1i, GR2s, GR2i, GR3s, GR3i As Integer
Dim Group1(), Group2(), Group3(), Sorting()
With ActiveWorkbook.Worksheets(1)
J = 1 'Array size
M = 0 'Array index
For Each i In R3Grp1
ReDim Preserve Sorting(J)
Sorting(M) = i.Value & " 1"
J = J + 1
M = M + 1
Next i
For Each i In R3Grp2
ReDim Preserve Sorting(J)
Sorting(M) = i.Value & " 2"
J = J + 1
M = M + 1
Next i
For Each i In R3Grp3
ReDim Preserve Sorting(J)
Sorting(M) = i.Value & " 3"
J = J + 1
M = M + 1
Next i
GR1s = 1 'Group1 Array size
GR1i = 0 'Group1 Array index
GR2s = 1 'Group2 Array size
GR2i = 0 'Group2 Array index
GR3s = 1 'Group2 Array size
GR3i = 0 'Group2 Array index
Erase Group1
Erase Group2
Erase Group3
For i = 0 To UBound(Sorting) - 1
S = Split(Sorting(i), " ")
If CInt(S(1)) + CInt(S(2)) = 3 Then
ReDim Preserve Group3(GR3s)
Group3(GR3i) = Sorting(i)
GR3s = GR3s + 1
GR3i = GR3i + 1
ElseIf CInt(S(1)) + CInt(S(2)) = 4 Then
ReDim Preserve Group2(GR2s)
Group2(GR2i) = Sorting(i)
GR2s = GR2s + 1
GR2i = GR2i + 1
ElseIf CInt(S(1)) + CInt(S(2)) = 5 Then
ReDim Preserve Group1(GR1s)
Group1(GR1i) = Sorting(i)
GR1s = GR1s + 1
GR1i = GR1i + 1
End If
Next i
For i = 0 To UBound(Group1) - 1
R3Dest1(i + 1).Value = Group1(i)
Next i
For i = 0 To UBound(Group2) - 1
R3Dest2(i + 1).Value = Group2(i)
Next i
For i = 0 To UBound(Group3) - 1
R3Dest3(i + 1).Value = Group3(i)
Next i
End With
End Sub

Sub Rotation4(R4Grp1 As Range, R4Grp2 As Range, R4Grp3 As Range, R4Dest1 As Range, R4Dest2 As Range, R4Dest3 As Range, R4Dest4 As Range)
Dim J, M As Integer
Dim Group(), Destination() As Variant
With ActiveWorkbook.Worksheets(1)
'****R2G1
J = 1 'Array size
M = 0 'Array index
For Each i In R4Grp1
ReDim Preserve Group(J)
Group(M) = i.Value & " 1"
J = J + 1
M = M + 1
Next i
J = 1 'Array size
M = 0 'Array index
For Each i In R4Dest1
ReDim Preserve Destination(J)
Destination(M) = i.Row
J = J + 1
M = M + 1
Next i
Call ShuffleArrayInPlace(Group)
Call ShuffleArrayInPlace(Destination)
For i = 0 To UBound(Group) - 1
.Range("D" & Destination(i)).Value = Group(i)
Next i
'****R2G2
R = 7
J = 1 'Array size
M = 0 'Array index
Erase Group
For Each i In R4Grp2
ReDim Preserve Group(J)
Group(M) = i.Value & " 2"
J = J + 1
M = M + 1
R = R + 1
Next i
J = 1 'Array size
M = 0 'Array index
Erase Destination
For Each i In R4Dest2
If i.Value = "" Then
ReDim Preserve Destination(J)
Destination(M) = i.Row
J = J + 1
M = M + 1
End If
Next i
Call ShuffleArrayInPlace(Group)
Call ShuffleArrayInPlace(Destination)
For i = 0 To UBound(Destination) - 1
.Range("D" & Destination(i)).Value = Group(i)
Next i
D = UBound(Destination)
J = 1 'Array size
M = 0 'Array index
Erase Destination
For Each i In R4Dest3
If i.Value = "" Then
ReDim Preserve Destination(J)
Destination(M) = i.Row
J = J + 1
M = M + 1
End If
Next i
Call ShuffleArrayInPlace(Destination)
For i = D To UBound(Group) - 1
.Range("D" & Destination(i)).Value = Group(i)
Next i
'****R2G3
J = 1 'Array size
M = 0 'Array index
Erase Group
For Each i In R4Grp3
ReDim Preserve Group(J)
Group(M) = i.Value & " 3"
J = J + 1
M = M + 1
Next i
J = 1 'Array size
M = 0 'Array index
Erase Destination
For Each i In R4Dest4
If i.Value = "" Then
ReDim Preserve Destination(J)
Destination(M) = i.Row
J = J + 1
M = M + 1
End If
Next i
Call ShuffleArrayInPlace(Group)
Call ShuffleArrayInPlace(Destination)
For i = 0 To UBound(Group) - 1
.Range("D" & Destination(i)).Value = Group(i)
Next i
End With
End Sub

[vert]

Charlie,

You still want the same 3 groups no matter the employees? 9 = 3 groups of 3, 12 = 3 groups of 4, etc?

mike

[coliervile]

Thanks Mike for looking at my question and helping out. I thought I could make the adjustments to work with 9, 12, and 15 employees, but no such luck.
You are correct on the groups;
9- employees Group 1 A1:A3, Group 2 A4:A6, and Group 3 A7:A9.
12- employees Group 1 A1:A4, Group 2 A5:A8, and Group 3 A9:A11.15- employees Group 1 A1:A5, Group 2 A6:A10, and Group 3 A11:A15.
With the same number of rotations.

Thanks again Mike

[vert]

Here you go man. It should work for 9 or greater employees as long as they are divisible by 3. If its less than 9 you will be prompted it cant run. If the employees are not divisible by 3 you will be prompted to add dummy names to round out the number. I've tested this on groups of 9 to 30 employees and it seems to work. Let me know if you have any issues with it.


Sub ShuffleArrayInPlace(InArray As Variant)
Dim N As Long, LastRow As Integer, GSize As Integer
Dim Temp As Variant
Dim J As Long
R = 3
LastRow = ActiveWorkbook.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
GSize = LastRow / 3

ReShuffle:
If UBound(InArray) >= 2 Then
Randomize
For N = LBound(InArray) To UBound(InArray) - 1
J = N
Do Until N <> J
J = CLng(((UBound(InArray) - 1) - LBound(InArray)) * Rnd + LBound(InArray))
Loop
If N <> J Then
Temp = InArray(N)
InArray(N) = InArray(J)
InArray(J) = Temp
End If
Next N
End If

If UBound(InArray) = GSize * 2 And IsNumeric(InArray(0)) Then
If InArray(0) > GSize And InArray(0) < (GSize * 2) + 1 Then
For N = LBound(InArray) To GSize - 2
If InArray(N) > GSize * 2 Then
Exit For
End If
Next N
If N = GSize - 1 Then
GoTo ReShuffle
End If
Else
For N = LBound(InArray) To GSize - 2
If InArray(N) < (GSize * 2) + 1 Then
Exit For
End If
Next N
If N = GSize - 1 Then
GoTo ReShuffle
End If
End If
End If
End Sub
Sub Rotation()
Dim Rng As Range, LastRow As Integer, GSize As Integer
Dim R2G1 As Range, R2G2 As Range, R2G3 As Range, R2D1 As Range, R2D2 As Range, R2D3 As Range, R2D4 As Range
Dim R3G1 As Range, R3G2 As Range, R3G3 As Range, R3D1 As Range, R3D2 As Range, R3D3 As Range
Dim R4G1 As Range, R4G2 As Range, R4G3 As Range, R4D1 As Range, R4D2 As Range, R4D3 As Range, R4D4 As Range

With ActiveWorkbook.Worksheets(1)
LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
If LastRow Mod 3 <> 0 Then
MsgBox "The employees must be divisible by 3. Add holder names like ""Blank1"" to fill out the table."
Exit Sub
ElseIf LastRow < 9 Then
MsgBox "Minimum of 9 employees."
Exit Sub
End If
GSize = LastRow / 3

Set Rng = .Range("B1:D" & LastRow) ' Rotation 2 - 4

Set R2G1 = .Range("A1:A" & GSize) ' Rotation 2 Group 1
Set R2G2 = .Range("A" & GSize + 1 & ":A" & GSize * 2) ' Rotation 2 Group 2
Set R2G3 = .Range("A" & (GSize * 2) + 1 & ":A" & LastRow) ' Rotation 2 Group 3
Set R2D1 = .Range("B" & GSize + 1 & ":B" & LastRow) ' Rotation 2 Destination 1
Set R2D2 = .Range("B" & (GSize * 2) + 1 & ":B" & LastRow) ' Rotation 2 Destination 2
Set R2D3 = .Range("B1:B" & GSize) ' Rotation 2 Destination 3
Set R2D4 = .Range("B1:B" & GSize * 2) ' Rotation 2 Destination 3

Set R3G1 = .Range("B1:B" & GSize) ' Rotation 3 Group 1
Set R3G2 = .Range("B" & GSize + 1 & ":B" & GSize * 2) ' Rotation 3 Group 2
Set R3G3 = .Range("B" & (GSize * 2) + 1 & ":B" & LastRow) ' Rotation 3 Group 3
Set R3D1 = .Range("C1:C" & GSize) ' Rotation 3 Destination 1
Set R3D2 = .Range("C" & GSize + 1 & ":C" & GSize * 2) ' Rotation 3 Destination 2
Set R3D3 = .Range("C" & (GSize * 2) + 1 & ":C" & LastRow) ' Rotation 3 Destination 3

Set R4G1 = .Range("C1:C" & GSize) ' Rotation 4 Group 1
Set R4G2 = .Range("C" & GSize + 1 & ":C" & GSize * 2) ' Rotation 4 Group 2
Set R4G3 = .Range("C" & (GSize * 2) + 1 & ":C" & LastRow) ' Rotation 4 Group 3
Set R4D1 = .Range("D" & GSize + 1 & ":D" & LastRow) ' Rotation 4 Destination 1
Set R4D2 = .Range("D" & (GSize * 2) + 1 & ":D" & LastRow) ' Rotation 4 Destination 2
Set R4D3 = .Range("D1:D" & GSize) ' Rotation 4 Destination 3
Set R4D4 = .Range("D1:D" & GSize * 2) ' Rotation 4 Destination 3

Rng.ClearContents

Call Rotation2(R2G1, R2G2, R2G3, R2D1, R2D2, R2D3, R2D4)
Call Rotation3(R3G1, R3G2, R3G3, R3D1, R3D2, R3D3)
Call Rotation4(R4G1, R4G2, R4G3, R4D1, R4D2, R4D3, R4D4)

'uncomment to removed rotation numbers from range
'For Each i In Rng
' S = Split(i.Value, " ")
' i.Value = S(0)
'Next i

End With
End Sub

Sub Rotation2(R2Grp1 As Range, R2Grp2 As Range, R2Grp3 As Range, R2Dest1 As Range, R2Dest2 As Range, R2Dest3 As Range, R2Dest4 As Range)
Dim J, M As Integer
Dim Group(), Destination() As Variant

With ActiveWorkbook.Worksheets(1)
'****R2G1

J = 1 'Array size
M = 0 'Array index
For Each i In R2Grp1
ReDim Preserve Group(J)
Group(M) = i.Value & " 1"
J = J + 1
M = M + 1
Next i

J = 1 'Array size
M = 0 'Array index
For Each i In R2Dest1
ReDim Preserve Destination(J)
Destination(M) = i.Row
J = J + 1
M = M + 1
Next i

Call ShuffleArrayInPlace(Group)
Call ShuffleArrayInPlace(Destination)

For i = 0 To UBound(Group) - 1
.Range("B" & Destination(i)).Value = Group(i)
Next i

'**********
'****R2G2

R = 7
J = 1 'Array size
M = 0 'Array index
Erase Group
For Each i In R2Grp2
ReDim Preserve Group(J)
Group(M) = i.Value & " 2"
J = J + 1
M = M + 1
R = R + 1
Next i

J = 1 'Array size
M = 0 'Array index
Erase Destination
For Each i In R2Dest2
If i.Value = "" Then
ReDim Preserve Destination(J)
Destination(M) = i.Row
J = J + 1
M = M + 1
End If
Next i

Call ShuffleArrayInPlace(Group)
Call ShuffleArrayInPlace(Destination)

For i = 0 To UBound(Destination) - 1
.Range("B" & Destination(i)).Value = Group(i)
Next i

d = UBound(Destination)

J = 1 'Array size
M = 0 'Array index
Erase Destination
For Each i In R2Dest3
If i.Value = "" Then
ReDim Preserve Destination(J)
Destination(M) = i.Row
J = J + 1
M = M + 1
End If
Next i

Call ShuffleArrayInPlace(Destination)

For i = d To UBound(Group) - 1
.Range("B" & Destination(i)).Value = Group(i)
Next i
'********
'****R2G3

J = 1 'Array size
M = 0 'Array index
Erase Group
For Each i In R2Grp3
ReDim Preserve Group(J)
Group(M) = i.Value & " 3"
J = J + 1
M = M + 1
Next i

J = 1 'Array size
M = 0 'Array index
Erase Destination
For Each i In R2Dest4
If i.Value = "" Then
ReDim Preserve Destination(J)
Destination(M) = i.Row
J = J + 1
M = M + 1
End If
Next i

Call ShuffleArrayInPlace(Group)
Call ShuffleArrayInPlace(Destination)

For i = 0 To UBound(Group) - 1
.Range("B" & Destination(i)).Value = Group(i)
Next i
End With
End Sub
Sub Rotation3(R3Grp1 As Range, R3Grp2 As Range, R3Grp3 As Range, R3Dest1 As Range, R3Dest2 As Range, R3Dest3 As Range)

Dim J, M, GR1s, GR1i, GR2s, GR2i, GR3s, GR3i As Integer
Dim Group1(), Group2(), Group3(), Sorting()

With ActiveWorkbook.Worksheets(1)

J = 1 'Array size
M = 0 'Array index
For Each i In R3Grp1
ReDim Preserve Sorting(J)
Sorting(M) = i.Value & " 1"
J = J + 1
M = M + 1
Next i
For Each i In R3Grp2
ReDim Preserve Sorting(J)
Sorting(M) = i.Value & " 2"
J = J + 1
M = M + 1
Next i
For Each i In R3Grp3
ReDim Preserve Sorting(J)
Sorting(M) = i.Value & " 3"
J = J + 1
M = M + 1
Next i

GR1s = 1 'Group1 Array size
GR1i = 0 'Group1 Array index
GR2s = 1 'Group2 Array size
GR2i = 0 'Group2 Array index
GR3s = 1 'Group2 Array size
GR3i = 0 'Group2 Array index
Erase Group1
Erase Group2
Erase Group3
For i = 0 To UBound(Sorting) - 1
S = Split(Sorting(i), " ")
If CInt(S(1)) + CInt(S(2)) = 3 Then
ReDim Preserve Group3(GR3s)
Group3(GR3i) = Sorting(i)
GR3s = GR3s + 1
GR3i = GR3i + 1
ElseIf CInt(S(1)) + CInt(S(2)) = 4 Then
ReDim Preserve Group2(GR2s)
Group2(GR2i) = Sorting(i)
GR2s = GR2s + 1
GR2i = GR2i + 1
ElseIf CInt(S(1)) + CInt(S(2)) = 5 Then
ReDim Preserve Group1(GR1s)
Group1(GR1i) = Sorting(i)
GR1s = GR1s + 1
GR1i = GR1i + 1
End If
Next i
For i = 0 To UBound(Group1) - 1
R3Dest1(i + 1).Value = Group1(i)
Next i
For i = 0 To UBound(Group2) - 1
R3Dest2(i + 1).Value = Group2(i)
Next i
For i = 0 To UBound(Group3) - 1
R3Dest3(i + 1).Value = Group3(i)
Next i
End With
End Sub
Sub Rotation4(R4Grp1 As Range, R4Grp2 As Range, R4Grp3 As Range, R4Dest1 As Range, R4Dest2 As Range, R4Dest3 As Range, R4Dest4 As Range)

Dim J, M As Integer
Dim Group(), Destination() As Variant

With ActiveWorkbook.Worksheets(1)
'****R2G1

J = 1 'Array size
M = 0 'Array index
For Each i In R4Grp1
ReDim Preserve Group(J)
Group(M) = i.Value & " 1"
J = J + 1
M = M + 1
Next i

J = 1 'Array size
M = 0 'Array index
For Each i In R4Dest1
ReDim Preserve Destination(J)
Destination(M) = i.Row
J = J + 1
M = M + 1
Next i
Call ShuffleArrayInPlace(Group)
Call ShuffleArrayInPlace(Destination)

For i = 0 To UBound(Group) - 1
.Range("D" & Destination(i)).Value = Group(i)
Next i
'**********
'****R2G2

R = 7
J = 1 'Array size
M = 0 'Array index
Erase Group
For Each i In R4Grp2
ReDim Preserve Group(J)
Group(M) = i.Value & " 2"
J = J + 1
M = M + 1
R = R + 1
Next i

J = 1 'Array size
M = 0 'Array index
Erase Destination
For Each i In R4Dest2
If i.Value = "" Then
ReDim Preserve Destination(J)
Destination(M) = i.Row
J = J + 1
M = M + 1
End If
Next i

Call ShuffleArrayInPlace(Group)
Call ShuffleArrayInPlace(Destination)
For i = 0 To UBound(Destination) - 1
.Range("D" & Destination(i)).Value = Group(i)
Next i

d = UBound(Destination)

J = 1 'Array size
M = 0 'Array index
Erase Destination
For Each i In R4Dest3
If i.Value = "" Then
ReDim Preserve Destination(J)
Destination(M) = i.Row
J = J + 1
M = M + 1
End If
Next i

Call ShuffleArrayInPlace(Destination)

For i = d To UBound(Group) - 1
.Range("D" & Destination(i)).Value = Group(i)
Next i
'********
'****R2G3

J = 1 'Array size
M = 0 'Array index
Erase Group
For Each i In R4Grp3
ReDim Preserve Group(J)
Group(M) = i.Value & " 3"
J = J + 1
M = M + 1
Next i

J = 1 'Array size
M = 0 'Array index
Erase Destination
For Each i In R4Dest4
If i.Value = "" Then
ReDim Preserve Destination(J)
Destination(M) = i.Row
J = J + 1
M = M + 1
End If
Next i

Call ShuffleArrayInPlace(Group)
Call ShuffleArrayInPlace(Destination)

For i = 0 To UBound(Group) - 1
.Range("D" & Destination(i)).Value = Group(i)
Next i
End With
End Sub

[coliervile]

Mike you have gone above and beyond what I was hoping for. I will look at it over weekend and give you some feedback. This why I enjoy coming to VBA Express for the expertise folks like yourself that are willing help someone. Thank you once again and have a great weekend.

[coliervile]

Good Morning Mike (vert)

I ran your coding this morning and i got an error msg. in this part of the code " If CInt(S(1)) + CInt(S(2)) = 3 Then" Run-time error '13': Type mismatch


Sub Rotation3(R3Grp1 As Range, R3Grp2 As Range, R3Grp3 As Range, R3Dest1 As Range, R3Dest2 As Range, R3Dest3 As Range)

Dim J, M, GR1s, GR1i, GR2s, GR2i, GR3s, GR3i As Integer
Dim Group1(), Group2(), Group3(), Sorting()

With ActiveWorkbook.Worksheets(1)

J = 1 'Array size
M = 0 'Array index
For Each i In R3Grp1
ReDim Preserve Sorting(J)
Sorting(M) = i.Value & " 1"
J = J + 1
M = M + 1
Next i
For Each i In R3Grp2
ReDim Preserve Sorting(J)
Sorting(M) = i.Value & " 2"
J = J + 1
M = M + 1
Next i
For Each i In R3Grp3
ReDim Preserve Sorting(J)
Sorting(M) = i.Value & " 3"
J = J + 1
M = M + 1
Next i

GR1s = 1 'Group1 Array size
GR1i = 0 'Group1 Array index
GR2s = 1 'Group2 Array size
GR2i = 0 'Group2 Array index
GR3s = 1 'Group2 Array size
GR3i = 0 'Group2 Array index
Erase Group1
Erase Group2
Erase Group3
For i = 0 To UBound(Sorting) - 1
S = Split(Sorting(i), " ")
If CInt(S(1)) + CInt(S(2)) = 3 Then
ReDim Preserve Group3(GR3s)
Group3(GR3i) = Sorting(i)
GR3s = GR3s + 1
GR3i = GR3i + 1
ElseIf CInt(S(1)) + CInt(S(2)) = 4 Then
ReDim Preserve Group2(GR2s)
Group2(GR2i) = Sorting(i)
GR2s = GR2s + 1
GR2i = GR2i + 1
ElseIf CInt(S(1)) + CInt(S(2)) = 5 Then
ReDim Preserve Group1(GR1s)
Group1(GR1i) = Sorting(i)
GR1s = GR1s + 1
GR1i = GR1i + 1
End If
Next i
For i = 0 To UBound(Group1) - 1
R3Dest1(i + 1).Value = Group1(i)
Next i
For i = 0 To UBound(Group2) - 1
R3Dest2(i + 1).Value = Group2(i)
Next i
For i = 0 To UBound(Group3) - 1
R3Dest3(i + 1).Value = Group3(i)
Next i
End With
End Sub


Thanks,
Charlie

[vert]

Could you give me the list of names you tried it with.

mike

[coliervile]

Mike,

I figured out what the "Type mismatch" was. I had one employee with the name of De Gennaro and when I typed it in as DeGennaro the coding ran fine.

[coliervile]

Hey Mike,

I forgot to metion that is an awesome code and works great.

[vert]

Glad I could help.

mike