הגרלת שמות מתוך רשימה

[יהודהע]

הגרלת שמות מתוך רשימה

שלום לכולם
אני עובד ב Win 10 עם אקסל 2016
לקראת פורים אני עושה הגרלה של משלוחי מנות בין משפחות
עמודה A זו רשימה של כל המשפחות
עמודה B הגרלה של אחד מהשמות מעמודה A
עמודה C הגרלה של אחד מהשמות מעמודה A

תנאים להגרלה:
1. עמודות B ו C לא יכילו באותה שורה את הערך בעמודה A באותה שורה (כדי שלא תוגרל למשפחה להביא לעצמה משלוח מנות)

2. עמודה B תהיה שונה מעמודה C (כדי שכל משפחה תקבל 2 משפחות שונות)

3. בעמודה B לא יהיו שם שיחזור על עצמו יותר מפעם אחת, כנ"ל לגבי עמודה C (כדי שכל משפחה תוגרל פעם אחת בכל עמודה וכל המשפחות יוגרלו)

אחרי חיפוש באינטרנט מצאתי פקודת מאקרו שעושה את העבודה בעמודה B, שכפלתי את הפקודה עבור עמודה C
הבעיה היא שהקוד לא מקיים את התנאי הראשון (שמשפחה לא תוגרל שהיא צריכה להביא לעצמה)

מצורף פה הקוד אשמח לעזרה איך לגרום שתנאי 1 יעבוד גם:

Sub randomCollection()
    Dim Names As New Collection
    Dim lastRow As Long, i As Long, j As Long, lin As Long
    Dim wk As Worksheet
 
    Set wk = Sheets("Sheet1")
 
    With wk
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
 
    For i = 2 To lastRow
        Names.Add wk.Cells(i, 1).Value, CStr(wk.Cells(i, 1).Value)
    Next i
 
    lin = 1
    For i = lastRow - 1 To 1 Step -1
        j = Application.WorksheetFunction.RandBetween(1, i)
        lin = lin + 1
        Range("B" & lin) = Names(j)
        Names.Remove j
    Next i
 
End Sub
Sub randomCollection2()
    Dim Names As New Collection
    Dim lastRow As Long, i As Long, j As Long, lin As Long
    Dim wk As Worksheet
 
    Set wk = Sheets("Sheet1")
 
    With wk
        lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
    End With
 
    For i = 2 To lastRow
        Names.Add wk.Cells(i, 1).Value, CStr(wk.Cells(i, 1).Value)
    Next i
 
    lin = 1
    For i = lastRow - 1 To 1 Step -1
        j = Application.WorksheetFunction.RandBetween(1, i)
        lin = lin + 1
        Range("C" & lin) = Names(j)
        Names.Remove j
    Next i
 
End Sub

תודה מראש למסייעים

 

[iyyi]

מבוטל

 

[יהודהע]

יש למישהו רעיון???