Assigning Random whilst checking front two rows to not duplicate the same values

S

studentlearner

New Member
Joined
Oct 7, 2021
Messages
30
Office Version
  1. 365
Platform
  1. Windows
So I have a list of data (E2:E13) that is to be randomized, after randomizing, I am to assign it to employees 2 and 3, the problem is that I'll have to check the front rows so that to not assign the same values and therefore preventing duplicates of the rows A and B.

Heres a data I'm working with:
AEL - Master Marking.xlsm
ABCDEFG
1Employee 1Employee 2Employee 3DataRandomizerRadomizer No Formula
2LokiWikiThorSeniorSenior
3ThorTonyKukuLuffy
4TonyLokiPukSanku
5KimPeanutLuffyThor
6PeanutCookieKimSankuMomo
7PukKisamaMomoPeanut
8LuffySankuKisamaKim
9SeniorMomoKimKuku
10KukuKukuPeanutKisama
11MomoSeniorTonyPuk
12SankuKekeLuffyThorTony
13KisamaPukLokiLoki
Sheet1
Cell Formulas
RangeFormula
F2:F13F2=SORTBY(E2:E13,RANDARRAY(ROWS(E2:E13)))
Dynamic array formulas.




And as you can see there's a duplicate on A7:C7 and A10:C10 even after the function is completed and I wish to prevent that, any help would be great thanks!
AEL - Master Marking.xlsm
ABCDEFG
1Employee 1Employee 2Employee 3DataRandomizerRadomizer No Formula
2LokiWikiKukuThorMomoKuku
3ThorSeniorSankuTonyKimSanku
4TonyLuffyPeanutLokiSeniorPeanut
5KimSankuSeniorPeanutKisamaSenior
6PeanutThorCookieKimThorPuk
7PukMomoPukKisamaKukuThor
8LuffyPeanutThorSankuPukLuffy
9SeniorKimLuffyMomoLuffyTony
10KukuKukuTonyKukuLokiLoki
11MomoKisamaLokiSeniorPeanutKisama
12SankuKekeKisamaLuffySankuMomo
13KisamaPukMomoPukTonyKim
Sheet1
Cell Formulas
RangeFormula
F2:F13F2=SORTBY(E2:E13,RANDARRAY(ROWS(E2:E13)))
Dynamic array formulas.



here's the macro i'm using to assign cells:
Sub Fill_Blanks_From_List2()
Dim StartRow As Long
Dim rA As Range

StartRow = 2
For Each rA In Range("B2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlBlanks).Areas
rA.Value = Range("G" & StartRow).Resize(rA.Count).Value
rA.Font.Color = vbRed
StartRow = StartRow + rA.Count
Next rA
End Sub
Sub Fill_Blanks_From_List3()
Dim StartRow As Long
Dim rA As Range

StartRow = 2
For Each rA In Range("C2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlBlanks).Areas
rA.Value = Range("G" & StartRow).Resize(rA.Count).Value
rA.Font.Color = vbRed
StartRow = StartRow + rA.Count
Next rA
End Sub
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
Sort by date Sort by votes
The formula below worked for me

1. Create a new column for the number of observations. I called it rank below. You can randomize the rank before setting it. The rank should not be a dynamic formula. Next, use Sortby and Index.


DataMatchRankSortbyIndex
Thor=H2=I21=SORTBY($E$2:$E$13,RANDARRAY(ROWS($E$2:$E$13)))=INDEX($H$2:$H$13,RANK(G2,$G$2:$G$13))
Tony=H3=I32=INDEX($H$2:$H$13,RANK(G3,$G$2:$G$13))
Loki=H4=I43=INDEX($H$2:$H$13,RANK(G4,$G$2:$G$13))
Peanut=H5=I54=INDEX($H$2:$H$13,RANK(G5,$G$2:$G$13))
Kim=H6=I65=INDEX($H$2:$H$13,RANK(G6,$G$2:$G$13))
Kisama=H7=I76=INDEX($H$2:$H$13,RANK(G7,$G$2:$G$13))
Sanku=H8=I87=INDEX($H$2:$H$13,RANK(G8,$G$2:$G$13))
Momo=H9=I98=INDEX($H$2:$H$13,RANK(G9,$G$2:$G$13))
Kuku=H10=I109=INDEX($H$2:$H$13,RANK(G10,$G$2:$G$13))
Senior=H11=I1110=INDEX($H$2:$H$13,RANK(G11,$G$2:$G$13))
Luffy=H12=I1211=INDEX($H$2:$H$13,RANK(G12,$G$2:$G$13))
Puk=H13=I1312=INDEX($H$2:$H$13,RANK(G13,$G$2:$G$13))
 
Upvote 0
studentlearner said:
I'll have to check the front rows so that to not assign the same values and therefore preventing duplicates of the rows A and B.
Click to expand...
Do you mean preventing duplicates of the rows in col A:B or col A:C?
Try this:
1. It doesn't use formula, only vba, so you don't need col F:G
2. I set maximum iteration = 1000, in case it goes to an endless loop, you may change that in this part:
qq = qq + 1: If qq = 1000 Then MsgBox "Reaching " & qq & " iterations. Please, restart the Sub": Exit Sub
3. I put the result in H2, you may change that in this part:
'put the result in H2
Range("H2").Resize(UBound(va, 1), 3) = va
4. It prevents duplicate in a row across col A:C.

VBA Code: 
Sub studentlearner_1()
Dim i As Long, qq As Long, n As Long
Dim txa As String
Dim va, vb, vc, vd, bb
Dim flag As Boolean

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

n = Range("A" & Rows.Count).End(xlUp).Row
txa = Range("E2:E" & n).Address
vd = Range("A2:C" & n)

Do
    va = vd
   
    vb = Evaluate("=SORTBY(" & txa & ",RANDARRAY(ROWS(" & txa & ")))")
    vc = Evaluate("=SORTBY(" & txa & ",RANDARRAY(ROWS(" & txa & ")))")
   
    For i = 1 To UBound(va, 1)
        If va(i, 2) = Empty Then va(i, 2) = vb(i, 1)
        If va(i, 3) = Empty Then va(i, 3) = vc(i, 1)
    Next
   
    flag = False
   
    For i = 1 To UBound(va, 1)
        bb = (Application.Index(va, i, 0))
        If UBound(bb) <> UBound(WorksheetFunction.Unique(bb, 1)) Then flag = True: Exit For
    Next
    qq = qq + 1: If qq = 1000 Then MsgBox "Reaching " & qq & " iterations. Please, restart the Sub": Exit Sub

Loop Until flag = False

'put the result in H2
Range("H2").Resize(UBound(va, 1), 3) = va

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

End Sub

Example:

studentlearner 1.xlsm
ABCDEFGHIJ
1Employee 1Employee 2Employee 3Data
2LokiWikiThorLokiWikiLuffy
3ThorTonyThorKukuKim
4TonyLokiTonyKimMomo
5KimPeanutKimLuffyThor
6PeanutCookieKimPeanutTonyCookie
7PukKisamaPukSankuTony
8LuffySankuLuffyPeanutKisama
9SeniorMomoSeniorThorSanku
10KukuKukuKukuKisamaSenior
11MomoSeniorMomoLokiPuk
12SankuKekeLuffySankuKekePeanut
13KisamaPukKisamaSeniorKuku
Sheet2
 
Upvote 0
Solution
Akuini said:
Do you mean preventing duplicates of the rows in col A:B or col A:C?
Try this:
1. It doesn't use formula, only vba, so you don't need col F:G
2. I set maximum iteration = 1000, in case it goes to an endless loop, you may change that in this part:
qq = qq + 1: If qq = 1000 Then MsgBox "Reaching " & qq & " iterations. Please, restart the Sub": Exit Sub
3. I put the result in H2, you may change that in this part:
'put the result in H2
Range("H2").Resize(UBound(va, 1), 3) = va
4. It prevents duplicate in a row across col A:C.

VBA Code: 
Sub studentlearner_1()
Dim i As Long, qq As Long, n As Long
Dim txa As String
Dim va, vb, vc, vd, bb
Dim flag As Boolean

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

n = Range("A" & Rows.Count).End(xlUp).Row
txa = Range("E2:E" & n).Address
vd = Range("A2:C" & n)

Do
    va = vd
  
    vb = Evaluate("=SORTBY(" & txa & ",RANDARRAY(ROWS(" & txa & ")))")
    vc = Evaluate("=SORTBY(" & txa & ",RANDARRAY(ROWS(" & txa & ")))")
  
    For i = 1 To UBound(va, 1)
        If va(i, 2) = Empty Then va(i, 2) = vb(i, 1)
        If va(i, 3) = Empty Then va(i, 3) = vc(i, 1)
    Next
  
    flag = False
  
    For i = 1 To UBound(va, 1)
        bb = (Application.Index(va, i, 0))
        If UBound(bb) <> UBound(WorksheetFunction.Unique(bb, 1)) Then flag = True: Exit For
    Next
    qq = qq + 1: If qq = 1000 Then MsgBox "Reaching " & qq & " iterations. Please, restart the Sub": Exit Sub

Loop Until flag = False

'put the result in H2
Range("H2").Resize(UBound(va, 1), 3) = va

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

End Sub

Example:

studentlearner 1.xlsm
ABCDEFGHIJ
1Employee 1Employee 2Employee 3Data
2LokiWikiThorLokiWikiLuffy
3ThorTonyThorKukuKim
4TonyLokiTonyKimMomo
5KimPeanutKimLuffyThor
6PeanutCookieKimPeanutTonyCookie
7PukKisamaPukSankuTony
8LuffySankuLuffyPeanutKisama
9SeniorMomoSeniorThorSanku
10KukuKukuKukuKisamaSenior
11MomoSeniorMomoLokiPuk
12SankuKekeLuffySankuKekePeanut
13KisamaPukKisamaSeniorKuku
Sheet2
Click to expand...
Hey Thank you, it works perfectly for my previous data, but can I check how do I modify it, if I were to have an extra cell, cause there seems to be a couple of duplicates on my new data sheet?

Copile.xlsm
MNOPQRSTUVWX
1Emplyee1Emplyee2Emplyee3DataBack-Up Employee
2Kon TommyMaestro JohnKon TommyMaestroTom
3Mick Alan BeckTomMick Alan Beck
4Mick Chris Beck PopoMick Chris Beck
5Jack Chris CathyTomJack Chris CathyTom
6Tom Chris NumMickTom Chris Num
7Tom Chris KatyTomTom Chris Katy
8Tom Jack TomTomTom Jack Tom
9Tom Popo SamTomTom Popo Sam Tommy
10Mick JackTomTomMick JackTom Katy
11John Alan Cathy KatyJohn Alan CathyTom
12Tom Alan KatyTomTom Alan Katy
13Tom John KatyTomTom John Katy
14MickTom PerryTomMickTom Perry
15MickTom Tom TommyMickTom Tom
16JohnTom NumTomJohnTom NumMick
17KonTom TomKonTom Tom John
18AlanTom NumAlanTom Num Popo
19Jack Popo NumJack Popo NumTom
20Jack John SamJack John Sam
21John Mick TomJohn Mick TomTom
22Alan Mick ChrisAlan Mick Chris
23Jack Mick CathyJack Mick CathyTom
24Alan PopoTomAlan PopoTom
25Kon John DeezKon John DeezTom
26Jack Mick PerryJack Mick PerryTom
27Alan Mick KinAlan Mick Kin
28Jack Mick TomJack Mick TomTom
29Alan Tommy CathyAlan Tommy CathyTom
30John Alan TomJohn Alan TomTom
31Chris KonTomChris KonTomTom
Original


here's the code:
Sub Macro1()

Dim i As Long, qq As Long, n As Long
Dim txa As String
Dim va, vb, vc, vd, bb
Dim flag As Boolean

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

n = Range("A" & Rows.Count).End(xlUp).Row
txa = Range("Q2:Q" & n).Address
vd = Range("M2:P" & n)

Do
va = vd

vc = Evaluate("=SORTBY(" & txa & ",RANDARRAY(ROWS(" & txa & ")))")

For i = 1 To UBound(va, 1)
If va(i, 4) = Empty Then va(i, 4) = vc(i, 1)
Next

flag = False

For i = 1 To UBound(va, 1)
bb = (Application.Index(va, i, 0))
If UBound(bb) <> UBound(WorksheetFunction.Unique(bb, 1)) Then flag = True: Exit For
Next
qq = qq + 1: If qq = 10000 Then MsgBox "Reaching " & qq & " iterations. Please, restart the Sub": Exit Sub

Loop Until flag = False

'put the result in H2
Range("U2").Resize(UBound(va, 1), 4) = va

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

End Sub
 
Upvote 0
1. How do you get items in col in col N:O? It already has duplicates in some rows, so it won't work even without the extra column.
2. Depend on your data, it's actually possible that you can't get the result that meets the criteria.
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
Errors when attempting to import text and check for duplicate rows in imported data
Replies
0
Views
532
SBMa
S
Guna13
  • Question
Help to Optimize Macro Code for Faster Performance
Replies
0
Views
757
Guna13
Guna13
R
  • Question
How to use VBA to randomly copy rows based on a specified value
Replies
2
Views
759
Herakles
H
Simon2001
  • Solved
Random Numbers (up to a max value) with no Duplicates - Draw Generator
2
Replies
11
Views
2K
Fluff
Fluff
G
  • Question
Delete non-duplicate rows
Replies
1
Views
337
Jimmypop
Jimmypop

Forum statistics

Threads
1,215,101
Messages
6,123,094
Members
449,095
Latest member
gwguy

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