Private Function rand_uniq(r As Integer, c As Integer, str As String) As Integer
Dim arr(255), foundarr(255)
Dim cell As Object
Dim used_r As Integer, i As Integer, j As Integer
used_r = Sheets("Sheet1").UsedRange.Rows.Count
For i = 0 To 255
arr(i) = i
Next
i = 0
For Each cell In Sheets("Sheet1").range("B2:B" & used_r)
If Trim(cell) = Trim(str) Then
foundarr(i) = CInt(Sheets("Sheet1").Cells(cell.Row, 3))
i = i + 1
End If
Next
For Each cell In Sheets("Sheet2").range("A2:A" & r - 1)
If Trim(cell) = Trim(str) Then
foundarr(i) = CInt(Sheets("Sheet2").Cells(cell.Row, 2))
i = i + 1
End If
Next
Call arr_minus(arr, foundarr)
rand_uniq = rand_arr(arr)
End Function
Private Function rand_arr(arr())
Dim x, y, z
z = -1
For Each c In arr
If c >= 0 Then z = 1
Next
If z < 0 Then
rand_arr = -1
Exit Function
End If
Do
y = Int(Rnd() * (UBound(arr) + 1))
x = arr(y)
Loop Until x >= 0
rand_arr = x
End Function
Private Sub arr_minus(ByRef arr1() As Variant, ByRef arr2 As Variant)
Dim i, j
For i = 0 To UBound(arr1)
For j = 0 To UBound(arr2)
If arr1(i) = arr2(j) Then arr1(i) = -1
Next
Next
End Sub
Sub call_rand()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic
Sheets("sheet2").Activate
Dim i As Integer, c As Integer
c = 2
i = 2
Do While Cells(i, c - 1) <> ""
If Cells(i, c) = "" Then
Cells(i, c) = rand_uniq(i, c, Cells(i, c - 1))
End If
DoEvents
i = i + 1
Loop
Application.ScreenUpdating = True
End Sub