Shuffle 2d array, sort 2d array with upto 3 keys, add a column to to a 2D array

From CodeCodex

Implementations[edit]

Visual Basic[edit]

'*************************************************************************
'*************Sub to sort a 2D array by upto 3 keys***********************
'*********************************By L Sood*******************************
Sub sort2darraybythreekeys(arrsub(), key1 As Integer, key2 As Integer, key3 As Integer)

Dim Temp1 As Variant
Dim Temp2 As Variant
Dim first As Integer
Dim Last As Long
Dim i As Long
Dim j As Long, k As Long, ncols As Integer


ncols = UBound(arrsub(), 2) - LBound(arrsub(), 2) + 1

ReDim Temp(ncols) As Variant


Last = UBound(arrsub(), 1)
If key1 = 0 Then GoTo 30

For i = 1 To Last
For j = i + 1 To Last
If arrsub(i, key1) >= arrsub(j, key1) Then

For k = 1 To ncols
    Temp(k) = arrsub(j, k)
    arrsub(j, k) = arrsub(i, k)
    arrsub(i, k) = Temp(k)
Next k


End If

If key2 = 0 Then GoTo 30

If (arrsub(i, key1) = arrsub(j, key1)) And (arrsub(i, key2) >= arrsub(j, key2)) Then

For k = 1 To ncols
    Temp(k) = arrsub(j, k)
    arrsub(j, k) = arrsub(i, k)
    arrsub(i, k) = Temp(k)
Next k


End If

If key3 = 0 Then GoTo 30

If (arrsub(i, key1) = arrsub(j, key1)) And (arrsub(i, key2) = arrsub(j, key2) And (arrsub(i, key3) >= arrsub(j, key3))) Then

For k = 1 To ncols
    Temp(k) = arrsub(j, k)
    arrsub(j, k) = arrsub(i, k)
    arrsub(i, k) = Temp(k)
Next k

End If
30
Next j
Next i
Erase Temp()
End Sub


'**Sub below adds a column to a 2D array either at the left end or right end****
'**********depending on whether beginning is set to True or False************
'*********a second array is returned with an added column********************
'****************by L Sood***************************************************

Sub addcolumntoarray(arrsub() As Variant, colsub() As Variant, arrcoladdedsub() As Variant, beginning As Boolean)

Dim ncols As Integer, nrows As Integer, i As Integer, j As Integer
ncols = UBound(arrsub(), 2) - LBound(arrsub(), 2) + 1: nrows = UBound(arrsub(), 1) - LBound(arrsub(), 1) + 1
ReDim arrcoladdedsub(1 To nrows, 1 To ncols + 1)

If beginning = True Then
    For i = 1 To nrows
        For j = 1 To ncols
            arrcoladdedsub(i, j + 1) = arrsub(i, j)
        Next j
    Next i

    For i = 1 To nrows
        arrcoladdedsub(i, LBound(arrcoladdedsub, 2)) = colsub(i)
    Next i

Else

    For i = 1 To nrows
        For j = 1 To ncols
            arrcoladdedsub(i, j) = arrsub(i, j)
        Next j
    Next i

    For i = 1 To nrows
        arrcoladdedsub(i, UBound(arrcoladdedsub, 2)) = colsub(i)
    Next i

End If

End Sub



'********************************************************
'Sub below Shuffles a 2D array*********************************
'**'****************by L Sood****************************

Sub arrayshuffle2d(arrsub())

    Dim xTemp As Variant
    'Dim yTemp As Variant
    Dim i As Long
    Dim j As Long
    Dim k As Integer
    Dim n As Long
    Dim ncols As Integer
    Dim first As Integer
    
    
    n = UBound(arrsub(), 1)
    first = LBound(arrsub(), 1)
    ncols = UBound(arrsub(), 2) - LBound(arrsub(), 2) + 1
    
    ReDim x(first To n) As Variant
    ReDim yTemp(1 To ncols) As Variant
    
    Randomize
    
    For i = first To n
    
        x(i) = Rnd
    Next i
    
    
    For j = 2 To n
        xTemp = x(j)
        For k = LBound(arrsub(), 2) To UBound(arrsub(), 2)
            yTemp(k) = arrsub(j, k)
        Next k
            For i = j - 1 To 1 Step -1
                If (x(i) <= xTemp) Then GoTo 10
                x(i + 1) = x(i)
                For k = LBound(arrsub(), 2) To UBound(arrsub(), 2)
                arrsub(i + 1, k) = arrsub(i, k)
                Next k
            Next i
        i = 0
10      x(i + 1) = xTemp
        For k = LBound(arrsub(), 2) To UBound(arrsub(), 2)
        arrsub(i + 1, k) = yTemp(k)
        Next k
    Next j

End Sub