Search code examples
excelvbaexcel-addinsvba6

Array that consists of numbers from 1 to 8 randomly in 8 rows and 8 columns, that doesn't repeat each rows and columns


Basically, I want to 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 columns. 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. I really want to have a dynamic random number that don't repeat each rows and columns like sudoku


Solution

  • 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())
        Dim LB As Long: LB = LBound(Arr): Dim BD As Long: BD = 1 - LB
        Dim T, i As Long, j As Long
        For i = UBound(Arr) To LB + 1 Step -1
            j = Int((i + BD) * Rnd) + LB
            T = Arr(i): Arr(i) = Arr(j): Arr(j) = T
        Next i
    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(FirstIndex To LastIndex, FirstIndex 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