Basically, I wanna create cross check inspections among 8 staffs randomly every month from January to July, The Purpose are in which each staff will not inspect the same other staff and will not inspect themself. Those 8 staffs data will be represented in 8 rows, and months schedule will be in 7 coloums. Can anybody figure out this dynamic random array in Excel?enter image description here

I have used randbetween, randarray, and several formulas, but those ones don't work., really wanna have a dynamic random number that don't repeat each rows and columns like sudoku

CodePudding user response：

Shuffle and Shift (Random)

• I'm not sure if it's 'random enough': the list of employees is shuffled (random) and is then shifted to the left (not random) in each row after the first row of the resulting array.
• Give it a try and let me know.

Main

Sub WriteSchedule()
    
    Const WORKSHEET_NAME As String = "Sheet1"
    Const FIRST_CELL As String = "A3"
    
    Dim Employees():
    Employees = Array("Amy", "Ann", "Joe", "Roy", "Ava", "Eva", "Mia", "Ian")
    Debug.Print Join(Employees, ", ")
    
    ShuffleArray Employees
    Debug.Print Join(Employees, ", ")
    
    Dim Data(): Data = GetShiftedArray(Employees, 1)
    PrintData Data, , , "Schedule"

    ' Reference the destination range.
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Sheets(WORKSHEET_NAME)
    Dim fCell As Range: Set fCell = ws.Range(FIRST_CELL)
    Dim rg As Range: Set rg = fCell.Resize(UBound(Data, 1), UBound(Data, 2))
    
    ' Write the values from the array to the destination range.
    rg.Value = Data

End Sub

Shuffle

Sub ShuffleArray( _
        ByRef Arr() As Variant)

    Dim Temp, i As Long, j As Long

    For i = UBound(Arr) To LBound(Arr) Step -1
        Temp = Arr(i)
        j = Int(i * Rnd)   1
        Arr(i) = Arr(j)
        Arr(j) = Temp
    Next

End Sub

Shift

Function GetShiftedArray( _
    Arr() As Variant, _
    Optional ByVal FirstIndex As Long = 0) _
As Variant

    Dim LB As Long: LB = LBound(Arr)
    Dim UB As Long: UB = UBound(Arr)
    
    Dim iDiff As Long: iDiff = LB - FirstIndex
    
    Dim LastIndex As Long: LastIndex = UB - iDiff
    
    Dim Data(): ReDim Data(1 To LastIndex, 1 To LastIndex)
    
    Dim Temp, r As Long, c As Long
    
    For r = FirstIndex To LastIndex
        If r = FirstIndex Then
            For c = FirstIndex To LastIndex
                Data(r, c) = Arr(c   iDiff)
            Next c
        Else
            Temp = Data(r - 1, FirstIndex)
            For c = FirstIndex To LastIndex - 1
                Data(r, c) = Data(r - 1, c   1)
            Next c
            Data(r, c) = Temp
        End If
    Next r
    
    GetShiftedArray = Data

End Function

Print 2D Array

Sub PrintData( _
        ByVal Data As Variant, _
        Optional ByVal RowDelimiter As String = vbLf, _
        Optional ByVal ColumnDelimiter As String = " ", _
        Optional ByVal Title As String = "PrintData Result")
    
    ' Store the limits in variables
    Dim rLo As Long: rLo = LBound(Data, 1)
    Dim rHi As Long: rHi = UBound(Data, 1)
    Dim cLo As Long: cLo = LBound(Data, 2)
    Dim cHi As Long: cHi = UBound(Data, 2)
    
    ' Define the arrays.
    Dim cLens() As Long: ReDim cLens(rLo To rHi)
    Dim strData() As String: ReDim strData(rLo To rHi, cLo To cHi)
    
    ' For each column ('c'), store strings of the same length ('cLen')
    ' in the string array ('strData').
    
    Dim r As Long, c As Long
    Dim cLen As Long
    
    For c = cLo To cHi
        ' Calculate the current column's maximum length ('cLen').
        cLen = 0
        For r = rLo To rHi
            strData(r, c) = CStr(Data(r, c))
            cLens(r) = Len(strData(r, c))
            If cLens(r) > cLen Then cLen = cLens(r)
        Next r
        ' Store strings of the same length in the current column
        ' of the string array.
        If c = cHi Then ' last row (no column delimiter ('ColumnDelimiter'))
            For r = rLo To rHi
                strData(r, c) = Space(cLen - cLens(r)) & strData(r, c)
            Next r
        Else ' all but the last row
            For r = rLo To rHi
                strData(r, c) = Space(cLen - cLens(r)) & strData(r, c) _
                    & ColumnDelimiter
            Next r
        End If
    Next c
    
    ' Write the title to the print string ('PrintString').
    Dim PrintString As String: PrintString = Title
    
    ' Append the data from the string array to the print string.
    For r = rLo To rHi
        PrintString = PrintString & RowDelimiter
        For c = cLo To cHi
            PrintString = PrintString & strData(r, c)
        Next c
    Next r
    
    ' Print the print string.
    Debug.Print PrintString

End Sub

CodePudding user response：

I can give you an algorithm, it's up to you to implement it.

For the first row, you create an collection of numbers from 1 to 8: [1, 2, 3, 4, 5, 6, 7, 8].
Each time, you pick a random number between 1 and the length of the collection. You take the number with that index and you remove it from the collection.

Example:
Collection    : [1, 2, 3, 4, 5, 6, 7, 8] (size=8)
Random number : 5
Random number's element : 5
Collection    : [1, 2, 3, 4, 6, 7, 8] (size=7)
Random number : 2
Random number's element : 2
Collection    : [1, 3, 4, 6, 7, 8] (size=6)
Random number : 5
Random number's element : 7
Collection    : [1, 3, 4, 6, 8] (size=5)
...

Like this, you get a first row : [5, 2, 7, ...]

For the second row, you create a new collection:
Collection    : [1, 2, 3, 4, 5, 6, 7, 8] (size=8)
First, you remove the "5", as it can't be chosen:
Collection    : [1, 2, 3, 4, 6, 7, 8] (size=7)
Random number : 3
Random number's element : 3
Then, you add the "5" and remove the "2", as the "2" can't be chosen in the second column:
Collection    : [1, 3, 4, 6, 7, 8, 5] (size=7)
Random number : 3
Random number's element : 4
Then, you add the "2" and remove the "7", as the "7" can't be chosen in the third column:
Collection    : [1, 3, 6, 7, 8, 5, 2] (size=6)
...