I am working on random numbers VBA and the below code picks a name from sheet2 and copies to sheet 1 and I can repeat these steps to pick 3 different names from that list. This code does a fantastic job when all the three names are in three consecutive rows but fails to pick 3 different names when they are in row 5th, row 10th and row 15th. Can someone help me pick three different names and put them in rows that are 5 rows apart? (1st name in 1st row, 2nd name in 5th row and 3rd name in 15th row) I am new to VBA!
Sub DDQ1()
Application.ScreenUpdating = False
Dim source, destination As Range
Set source = Sheets("sheet2").Range("A60:A81")
Sheets("sheet1").Activate
Set destination = ActiveSheet.Range("B53")
ReDim randoms(1 To source.Rows.Count)
destrow = 0
For i = 1 To destination.Rows.Count
If destination(i) = "" Then: destrow = i: Exit For
Next i
If destrow = 0 Then: MsgBox "no more room in destination range": Exit Sub
For i = 1 To UBound(randoms): randoms(i) = Rnd(): Next i
ipick = 0: tries = 0
Do While ipick = 0 And tries < UBound(randoms)
tries = tries + 1
minrnd = WorksheetFunction.Min(randoms)
For i = 1 To UBound(randoms)
If randoms(i) = minrnd Then
picked_before = False
For j = 1 To destrow - 1
If source(i) = destination(j) Then: picked_before = True: randoms(i) = 2: Exit For
Next j
If Not picked_before Then: ipick = i
Exit For
End If
Next i
Loop
If ipick = 0 Then: MsgBox "no more unique name possible to pick": Exit Sub
destination(destrow) = source(ipick)
Application.ScreenUpdating = True
End Sub
Aucun commentaire:
Enregistrer un commentaire