Random Selection in Column w/ No Repetition in Row

P

peerogel

Board Regular
Joined
Jan 25, 2011
Messages
108
I need help creating a schedule that generates random selections with limited repetitions. The selections will go down the column with limited repetitions down the row. I thought I was on the right track but I'm stuck. https://www.mrexcel.com/forum/excel-questions/1064540-random-selection-repetition-rows.html

I was trying to figure the random selection thing and add from there, but cant figure out how to get the pre-assigned days off. I hoping I could skip the selection if the cell was not empty but that only ends the random selection for the row.

I hope I can get some guidance, im trying to make something like the table below. The x's represent the days off. Times would be how many times that item on the list has to be used on the column for the day. Thanks in advance.

[TABLE="width: 500"]
<tbody>[TR]
[TD]Employee[/TD]
[TD]Sun[/TD]
[TD]Mon[/TD]
[TD]Tue[/TD]
[TD]Wed[/TD]
[TD]Thu[/TD]
[TD]Fri[/TD]
[TD]Sat[/TD]
[TD]Sun[/TD]
[TD]Mon[/TD]
[TD]Tue[/TD]
[TD]Wed[/TD]
[TD]Thu[/TD]
[TD]Fri[/TD]
[TD]Sat[/TD]
[TD][/TD]
[TD][/TD]
[TD]List[/TD]
[TD]Times[/TD]
[/TR]
[TR]
[TD]Employee1[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD]training[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]L10[/TD]
[TD]0[/TD]
[/TR]
[TR]
[TD]
Employee2​
<strike></strike>[/TD]
[TD]<strike></strike>[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]L11[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]
Employee3​
<strike></strike>[/TD]
[TD]<strike></strike>[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]L12[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]
Employee4​
<strike></strike>[/TD]
[TD]<strike></strike>[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]L13[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]
Employee5​
<strike></strike>[/TD]
[TD]<strike></strike>[/TD]
[TD][/TD]
[TD][/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]vacation[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]L14[/TD]
[TD]4[/TD]
[/TR]
[TR]
[TD]
Employee6​
<strike></strike>[/TD]
[TD]<strike></strike>[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]L15[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]
Employee7​
<strike></strike>[/TD]
[TD]<strike></strike>[/TD]
[TD][/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]leave[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]L16[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]
Employee8​
<strike></strike>[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]L17[/TD]
[TD]5[/TD]
[/TR]
[TR]
[TD]
Employee9​
<strike></strike>[/TD]
[TD]<strike></strike>[/TD]
[TD][/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]L18[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]
Employee10​
<strike></strike>[/TD]
[TD]<strike></strike>[/TD]
[TD][/TD]
[TD][/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]L19[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]
Employee11​
<strike></strike>[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]L20[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]
Employee12​
<strike></strike>[/TD]
[TD]<strike></strike>[/TD]
[TD][/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]testing[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]TRA[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]
Employee13​
<strike></strike>[/TD]
[TD]<strike></strike>[/TD]
[TD][/TD]
[TD][/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]WK[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]
Employee14​
<strike></strike>[/TD]
[TD]<strike></strike>[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]SP[/TD]
[TD]1[/TD]
[/TR]
</tbody>[/TABLE]
 
Sort by date Sort by votes
I was looking through old files and found one that had a code written. I understand most of the code but I'm having issues understanding a few things. The selection doesn't appear to be random though (I think). The sheet has employees color coded for those employees that can do special assignments. The code works fine but it keeps getting an 1004 error on those parts of the code where it does a VLookup. If I remove those VLookup sections it works fine, but now that I see them they are needed. This part of the code (For Each cel In Vert) has me confused, Im not sure how its being used. Not sure if they stopped using it because they couldn't get it to work or if it was lost in the bunch.
Code: 
Sub SAMPLE()
Application.ScreenUpdating = False
Dim cnt As Integer
Dim r As Range, r1 As Range
Set r1 = Selection
Dim ctr As Long
Dim i As Integer, a As Integer
Dim Ch As Integer
Dim y As Integer, z As Integer, x As Integer, j As Integer
Dim L11 As Integer, L12 As Integer, L13 As Integer, BK As Integer, L14 As Integer, PIT As Integer, NR As Integer
Dim PRO As Integer, RC As Integer, TRA As Integer, CAM As Integer, L15 As Integer, L16 As Integer
Dim L17 As Integer, L18 As Integer, L19 As Integer, L20 As Integer, CPNT As Integer, UN As Integer
Dim Total As Integer, iChoose As Integer
Dim dif As Integer, difLD As Integer, ldOD As Integer, ldRC As Integer, ldPIT As Integer, Student As Integer
Dim Redo As Long
Dim Zone As String
Dim Names As Range, Stars As Range, Details As Range, sGrid As Range, Matrix As Range, Vert As Range
Set Names = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
Set Start = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
Set sGrid = Range(Range("E2"), Range("R" & Rows.Count).End(xlUp))
Set Details = Range(Sheets(5).Range("A1"), Sheets(5).Range("A" & Rows.Count).End(xlUp))
Set Details = Details.Resize(Details.Rows.Count, 9)
For Each cel In Names
    If Application.WorksheetFunction.VLookup(cel.Offset(, 1), Details, 8, False) = "RC" Then
        cel.Offset(, 2).Value = "RC"
        cel.Offset(, 2).Interior.ColorIndex = 6
    End If
Next cel
For x = 5 To 18
For Each cel In Start
    If cel.Offset(, 1).Value = "Trainee" And cel.Offset(, x - 2).Value = "" Then
        Student = Student + 1
    End If
Next cel
Set Vert = Range(Cells(2, x), Cells(Names.Rows.Count + 1, x))

Total = Application.WorksheetFunction.CountBlank(Vert)
dif = 0
L11 = Range("BD6").Value
L12 = Range("BD7").Value
NR = Range("BD8").Value
L13 = Range("BD9").Value
BK = Range("BD10").Value
L14 = Range("BD11").Value
PIT = Range("BD12").Value
PRO = Range("BD14").Value
CAM = Range("BD16").Value
TRA = Range("BD15").Value
RC = Range("BD13").Value
L15 = Range("BD17").Value
L16 = Range("BD18").Value
L17 = Range("BD19").Value
L18 = Range("BD20").Value
L19 = Range("BD21").Value
CPNT = Range("BD22").Value
L20 = Range("BD23").Value
UN = Range("BD24").Value

dif = (L11 + L12 + NR + L13 + L14 + L15 + L16 + L17 + L18 + L19 + L20 + BK + PIT + PRO + CAM + TRA + RC + CPNT) - Total
If dif <= 0 Then
    Do Until dif = 0
        If dif = 0 Then Exit Do
        L18 = L18 + 1
        dif = dif + 1
        If dif = 0 Then Exit Do
        L17 = L17 + 1
        dif = dif + 1
        If dif = 0 Then Exit Do
        L11 = L11 + 1
        dif = dif + 1
        If dif = 0 Then Exit Do
        L12 = L12 + 1
        dif = dif + 1
        If dif = 0 Then Exit Do
        L13 = L13 + 1
        dif = dif + 1
        If dif = 0 Then Exit Do
        L14 = L14 + 1
        dif = dif + 1
        If dif = 0 Then Exit Do
        L15 = L15 + 1
        dif = dif + 1
        If dif = 0 Then Exit Do
        PRO = PRO + 1
        dif = dif + 1
        If dif = 0 Then Exit Do
        TRA = TRA + 1
        dif = dif + 1
        If dif = 0 Then Exit Do
        L17 = L17 + 1
        dif = dif + 1
        If dif = 0 Then Exit Do
        CAM = CAM + 1
        dif = dif + 1
        If dif = 0 Then Exit Do
        L20 = L20 + 1
        dif = dif + 1
    Loop
Else
    Do Until dif = 0
        If dif = 0 Then Exit Do
            If L19 > 0 Then
                L19 = L19 - 1
                dif = dif - 1
            End If
        If dif = 0 Then Exit Do
            If L16 > 0 Then
                L16 = L16 - 1
                dif = dif - 1
            End If
        If dif = 0 Then Exit Do
            If L15 > 0 Then
                L15 = L15 - 1
                dif = dif - 1
            End If
        If dif = 0 Then Exit Do
            If L13 > 0 Then
                L13 = L13 - 1
                dif = dif - 1
            End If
        If dif = 0 Then Exit Do
            If L14 > 0 Then
                L14 = L14 - 1
                dif = dif - 1
            End If
        If dif = 0 Then Exit Do
            If L12 > 0 Then
                L12 = L12 - 1
                dif = dif - 1
            End If
        If dif = 0 Then Exit Do
    Loop
End If
For Each cel In Vert
    If cel.Value = vbNullString And Cells(cel.Row(), 1).Interior.ColorIndex = 45 Then
        If (Application.WorksheetFunction.VLookup(Cells(cel.Row(), 2), Details, 4, False) = "LD" Or Application.WorksheetFunction.VLookup(Cells(cel.Row(), 2), Details, 4, False) = "ADD") _
        And Application.WorksheetFunction.VLookup(Cells(cel.Row(), 2), Details, 8, False) = "RC" And Cells(cel.Row(), x) = vbNullString Then
            If ldRC < RC Then
                ldRC = ldRC + 1
            Else
                ldOD = ldOD + 1
            End If
            
        ElseIf (Application.WorksheetFunction.VLookup(Cells(cel.Row(), 2), Details, 4, False) = "LD" Or Application.WorksheetFunction.VLookup(Cells(cel.Row(), 2), Details, 4, False) = "ADD") _
        And Application.WorksheetFunction.VLookup(Cells(cel.Row(), 2), Details, 5, False) = "PIT" And Cells(cel.Row(), x) = vbNullString Then
            If ldPIT < Range("BD13").Value Then
                ldPIT = ldPIT + 1
            Else
                ldOD = ldOD + 1
            End If
        ElseIf Application.WorksheetFunction.VLookup(Cells(cel.Row(), 2), Details, 4, False) = "LD" Or Application.WorksheetFunction.VLookup(Cells(cel.Row(), 2), Details, 4, False) = "ADD" Then
            ldOD = ldOD + 1
        End If
    End If
Next cel
With Vert
    If ldRC > 0 Then
    Set cel = Vert.Find("", Vert.Cells(1, 1), xlValues, xlPart)
        Do Until RC = 0
            If (Application.WorksheetFunction.VLookup(Cells(cel.Row(), 2), Details, 4, False) = "LD" Or Application.WorksheetFunction.VLookup(Cells(cel.Row(), 2), Details, 4, False) = "ADD") _
            And Application.WorksheetFunction.VLookup(Cells(cel.Row(), 2), Details, 8, False) = "RC" And cel.Value = "" Then
                Cells(cel.Row(), x).Value = "RC"
                RC = RC - 1
                ldRC = ldRC - 1
                Total = Total - 1
            End If
            Set cel = .Find("", cel, xlValues, xlPart)
        Loop
    End If
End With
        
If RC > 0 Then
    Do Until RC = 0
    Set cel = Cells(Int(Rnd * Names.Rows.Count) + 2, 1)
        If Application.WorksheetFunction.VLookup(Cells(cel.Row(), 2), Details, 8, False) = "RC" And Cells(cel.Row(), x) = "" Then
            If (Application.WorksheetFunction.VLookup(Cells(cel.Row(), 2), Details, 4, False) = "LD" Or Application.WorksheetFunction.VLookup(Cells(cel.Row(), 2), Details, 4, False) = "ADD") _
            And Application.WorksheetFunction.VLookup(Cells(cel.Row(), 2), Details, 5, False) = "PIT" And Cells(cel.Row(), x) = vbNullString Then
                ldPIT = ldPIT - 1
            End If
                Cells(cel.Row(), x).Value = "RC"
                RC = RC - 1
                Total = Total - 1
        End If
    Loop
End If

    With Vert
        If ldPIT > 0 Then
            Set cel = Vert.Find("", Vert.Cells(1, 1), xlValues, xlPart)
                Do Until ldPIT = 0
                    If (Application.WorksheetFunction.VLookup(Cells(cel.Row(), 2), Details, 4, False) = "LD" Or Application.WorksheetFunction.VLookup(Cells(cel.Row(), 2), Details, 4, False) = "ADD") _
                    And Application.WorksheetFunction.VLookup(Cells(cel.Row(), 2), Details, 5, False) = "PIT" And cel.Value = "" Then
                        cel.Value = "PIT"
                        PIT = PIT - 1
                        ldPIT = ldPIT - 1
                        Total = Total - 1
                    End If
                    Set cel = .Find("", cel, xlValues, xlPart)
                Loop
        End If
    End With
    
If PIT > 0 Then
    Do Until PIT <= 0
    Set cel = Cells(Int(Rnd * Names.Rows.Count) + 2, 1)
        If Application.WorksheetFunction.VLookup(Cells(cel.Row(), 2), Details, 5, False) = "PIT" And Cells(cel.Row(), x) = "" Then
           Cells(cel.Row(), x) = "PIT"
            PIT = PIT - 1
            Total = Total - 1
            If cel.Interior.ColorIndex = 45 Then ldOD = ldOD - 1
                If Application.WorksheetFunction.VLookup(Cells(cel.Row(), 2), Details, 9, False) <> "" Then
                    Set cel = Start.Find(Application.WorksheetFunction.VLookup(Cells(cel.Row(), 2), Details, 9, False), Start.Cells(1, 1), xlValues, xlWhole)
                    cel.Offset(, x - 2).Value = "PRO"
                    PRO = PRO - 1
                    Student = Student - 1
                    Total = Total - 1
                End If
        End If
   Loop
End If
With Vert
    If ldOD > 0 Then
        Set cel = Vert.Find("", Vert.Cells(1, 1), xlValues, xlPart)
            Do Until ldOD = 0
                If (Application.WorksheetFunction.VLookup(Cells(cel.Row(), 2), Details, 4, False) = "LD" _
                Or Application.WorksheetFunction.VLookup(Cells(cel.Row(), 2), Details, 4, False) = "ADD") Then
                    Cells(cel.Row(), x) = "CAM"
                    CAM = CAM - 1
                    ldOD = ldOD - 1
                    Total = Total - 1
                End If
                Set cel = .Find("", cel, xlValues, xlPart)
            Loop
    End If
End With
If CAM < 0 Then
    Do Until CAM = 0
        L13 = L13 - 1
        CAM = CAM + 1
        Total = Total - 1
    Loop
End If

Do Until BK = 0
Set cel = Cells(Int(Rnd * Names.Rows.Count) + 2, 1)
    If Cells(cel.Row(), x) = "" And (cel.Interior.ColorIndex = 8 Or cel.Interior.ColorIndex = 14) _
    And Cells(cel.Row(), x).Offset(, -1) <> "Bikes" And Cells(cel.Row(), x).Offset(, -2) <> "Bikes" _
    And Application.WorksheetFunction.CountIf(Range(Cells(cel.Row, 5), Cells(cel.Row, 18)), "Bikes") < 6 Then
        Cells(cel.Row(), x) = "Bikes"
        BK = BK - 1
        Total = Total - 1
    End If
Loop

Do Until CPNT = 0
Set cel = Cells(Int(Rnd * Names.Rows.Count) + 2, 1)
    If Cells(cel.Row(), x) = "" And Cells(cel.Row(), 1).Interior.ColorIndex <> 45 _
    And Application.WorksheetFunction.CountIf(Range(Cells(cel.Row, 5), Cells(cel.Row, 18)), "808") < 4 Then
        Cells(cel.Row(), x) = "808"
        CPNT = CPNT - 1
        Total = Total - 1
    End If
Loop
Do Until TRA = 0
Set cel = Cells(Int(Rnd * Names.Rows.Count) + 2, 1)
    If Cells(cel.Row(), x) = "" And Cells(cel.Row(), 1).Interior.ColorIndex <> 45 Then
        Cells(cel.Row(), x) = "TRA"
        TRA = TRA - 1
        Total = Total - 1
    End If
Loop
Do Until PRO = 0
Set cel = Cells(Int(Rnd * Names.Rows.Count) + 2, 1)
    If Cells(cel.Row(), x) = "" And Cells(cel.Row(), 1).Interior.ColorIndex <> 45 Then
        Cells(cel.Row(), x) = "PRO"
        PRO = PRO - 1
        Total = Total - 1
    End If
Loop
Do Until L11 <= 0
Set cel = Cells(Int(Rnd * Names.Rows.Count) + 2, 1)
    If Cells(cel.Row(), x) = "" And Cells(cel.Row(), 1).Interior.ColorIndex <> 45 Then
        Cells(cel.Row(), x) = "L11"
        L11 = L11 - 1
        Total = Total - 1
    End If
Loop
Do Until L12 = 0
Set cel = Cells(Int(Rnd * Names.Rows.Count) + 2, 1)
    If Cells(cel.Row(), x) = "" And Cells(cel.Row(), 1).Interior.ColorIndex <> 45 Then
        Cells(cel.Row(), x) = "L12"
        L12 = L12 - 1
        Total = Total - 1
    End If
Loop
Do Until NR = 0
Set cel = Cells(Int(Rnd * Names.Rows.Count) + 2, 1)
    If Cells(cel.Row(), x) = "" And Cells(cel.Row(), 1).Interior.ColorIndex <> 45 Then
        Cells(cel.Row(), x) = "NR"
        NR = NR - 1
        Total = Total - 1
    End If
Loop
Do Until L13 = 0
Set cel = Cells(Int(Rnd * Names.Rows.Count) + 2, 1)
        If Cells(cel.Row(), x) = "" And Cells(cel.Row(), 1).Interior.ColorIndex <> 45 Then
            Cells(cel.Row(), x) = "L13"
            L13 = L13 - 1
            Total = Total - 1
        End If
    End If
Loop
Do Until L14 = 0
Set cel = Cells(Int(Rnd * Names.Rows.Count) + 2, 1)
    If Cells(cel.Row(), x) = "" And Cells(cel.Row(), 1).Interior.ColorIndex <> 45 Then
        Cells(cel.Row(), x) = "L14"
        L14 = L14 - 1
        Total = Total - 1
    End If
Loop
Do Until L15 = 0
Set cel = Cells(Int(Rnd * Names.Rows.Count) + 2, 1)
    If Cells(cel.Row(), x) = "" And Cells(cel.Row(), 1).Interior.ColorIndex <> 45 Then
        Cells(cel.Row(), x) = "L15"
        L15 = L15 - 1
        Total = Total - 1
    End If
Loop
Do Until L16 = 0
Set cel = Cells(Int(Rnd * Names.Rows.Count) + 2, 1)
    If Cells(cel.Row(), x) = "" And Cells(cel.Row(), 1).Interior.ColorIndex <> 45 Then
        Cells(cel.Row(), x) = "L16"
        L16 = L16 - 1
        Total = Total - 1
    End If
Loop
Do Until L17 = 0
Set cel = Cells(Int(Rnd * Names.Rows.Count) + 2, 1)
    If Cells(cel.Row(), x) = "" And Cells(cel.Row(), 1).Interior.ColorIndex <> 45 Then
        Cells(cel.Row(), x) = "L17"
        L17 = L17 - 1
        Total = Total - 1
    End If
Loop
Do Until L18 = 0
Set cel = Cells(Int(Rnd * Names.Rows.Count) + 2, 1)
    If Cells(cel.Row(), x) = "" And Cells(cel.Row(), 1).Interior.ColorIndex <> 45 Then
        Cells(cel.Row(), x) = "L18"
        L18 = L18 - 1
        Total = Total - 1
    End If
Loop
Do Until L19 = 0
Set cel = Cells(Int(Rnd * Names.Rows.Count) + 2, 1)
    If Cells(cel.Row(), x) = "" And Cells(cel.Row(), 1).Interior.ColorIndex <> 45 Then
        Cells(cel.Row(), x) = "L19"
        L19 = L19 - 1
        Total = Total - 1
    End If
Loop
Do Until L20 = 0
Set cel = Cells(Int(Rnd * Names.Rows.Count) + 2, 1)
    If Cells(cel.Row(), x) = "" And Cells(cel.Row(), 1).Interior.ColorIndex <> 45 Then
        Cells(cel.Row(), x) = "L20"
        L20 = L20 - 1
        Total = Total - 1
    End If
Loop

If CAM > 0 Then
    Do Until CAM = 0
    Set cel = Cells(Int(Rnd * Names.Rows.Count) + 2, 1)
        If Cells(cel.Row(), x) = "" Then
            Cells(cel.Row(), x) = "CAM"
            CAM = CAM - 1
            Total = Total - 1
        End If
    Loop
End If
If UN > 0 Then
    Do Until UN = 0
    Set cel = Cells(Int(Rnd * Names.Rows.Count) + 2, 1)
        If Cells(cel.Row(), x) = "" Then
            Cells(cel.Row(), x) = "UN"
            UN = UN - 1
            Total = Total - 1
        End If
    Loop
End If

ldPIT = 0
ldOD = 0
ldRC = 0
Next x
End Sub
 
Upvote 0

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
You must log in or register to reply here.

Similar threads

D
  • Solved
Filter on decremental list
Replies
5
Views
94
Peter_SSs
Peter_SSs
A
  • Question Question
VBA help - Locking & unlocking on certain times of day
2
Replies
15
Views
327
dmt32
D
F
  • Solved
How to change value from data validation based on value in col A?
Replies
5
Views
332
Eric W
Eric W
N
  • Question Question
Adding to an existing MACRO
Replies
2
Views
103
Northern NY Design
N
J
  • Solved
Formula Filled Dates
Replies
4
Views
479
Fluff
Fluff

Forum statistics

Threads
1,223,884
Messages
6,175,177
Members
452,615
Latest member
bogeys2birdies

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top