Как я могу перемешать 2D массив в VBA?

Question

У меня есть следующий сценарий, чтобы поместить в список список людей с такими навыками, а затем сопоставить первое совпадение с клиентом с таким же навыком.Каждый раз, когда он запускается, результаты одинаковы.Я хотел бы, чтобы это был случайный порядок массива, но сохраняя два столбца в массиве вместе.Как я могу перемешать (переставить) массив, который сохраняет строки в массиве одинаковыми?Или лучше стереть массив, случайным образом отсортировать столбцы и восстановить массив?

Sub Assign()

Dim arOne()
ReDim arOne(1000, 15)
Dim o As Integer
Dim p As Integer
Dim StartTime As Double
Dim MinutesElapsed As String



p = 0
o = 0

For i = 2 To 920
    If Cells(i, 12).Value <> Cells(i - 1, 12) Then
        p = p + 1
        arOne(p, 0) = Cells(i, 12).Value
        arOne(p, 1) = Cells(i, 13).Value
        o = 2
    Else
        arOne(p, o) = Cells(i, 13).Value
        o = o + 1
    End If
Next


For i = 2 To 612
    For o = LBound(arOne, 1) + 1 To UBound(arOne, 1)
        If arOne(o, 0) <> "" Then
            iUsed = Application.WorksheetFunction.CountIf(Range("C2:C" & i), "=" & arOne(o, 0))
            If iUsed < Application.WorksheetFunction.VLookup(arOne(o, 0), Range("Q2:R62"), 2, False) Then
                For j = LBound(arOne, 2) + 1 To UBound(arOne, 2)
                    If arOne(o, j) = Cells(i, 2).Value Then
                        Cells(i, 3).Value = arOne(o, 0)
                        ActiveSheet.Calculate
                        GoTo NextIR
                    End If
                Next j
            End If
        End If
    Next o
NextIR:
Next i

End Sub

Answer 1

Несколько циклов и множественный доступ к объектам диапазона делают ваш код очень, очень медленным (я не знаю, важна ли производительность).

Я бы прочитал все необходимые данные в массивы и использовал бы filter и rnd toполучить случайного человека с соответствующим навыком:

Option Explicit

Sub PeopleBusiness()
Dim People, Customers, FilterArray
Dim I As Long, Idx As Long
    People = Application.Transpose([L2:L920 & "|" & M2:M8])
    Customers = Range("A2:C612").Value2
    For I = 1 To UBound(Customers, 1)
        FilterArray = Filter(People, Customers(I, 2))
        If UBound(FilterArray) > -1 Then
            Idx = Round(Rnd() * UBound(FilterArray), 0)
            Customers(I, 3) = Left(FilterArray(Idx), InStr(1, FilterArray(Idx), "|") - 1)
        End If
    Next I
    Range("A2:C612").Value = Customers
End Sub

Answer 2

Мне удалось выполнить то, что мне было нужно, стерев массив и повторно обработав его после сортировки данных по номеру rand () в таблице.Выполнение задания 7000 занимает около 15 минут, но это намного лучше, чем 7+ часов, которые требуется выполнить вручную.

Sub Assign()
Dim arOne()
ReDim arOne(1000, 15)
Dim o As Integer
Dim p As Integer
Dim StartTime As Double
Dim MinutesElapsed As String
Application.Calculation = xlAutomatic
StartTime = Timer
NextIR:
ReDim arOne(1000, 15)
p = 0
o = 0

QAlr = Sheets("Sheet1").Range("L" & Rows.Count).End(xlUp).Row

For I = 2 To QAlr
    If Cells(I, 12).Value <> Cells(I - 1, 12) Then
        p = p + 1
        arOne(p, 0) = Cells(I, 12).Value
        arOne(p, 1) = Cells(I, 13).Value
        o = 2
    Else
        arOne(p, o) = Cells(I, 13).Value
        o = o + 1
    End If
Next

AQAlr = Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
AgtLr = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row

For I = AQAlr + 1 To AgtLr
    For o = LBound(arOne, 1) + 1 To UBound(arOne, 1)
        If arOne(o, 0) <> "" Then
            iUsed = Application.WorksheetFunction.CountIf(Range("C2:C" & I), "=" & arOne(o, 0))
            If iUsed < Application.WorksheetFunction.VLookup(arOne(o, 0), Range("Q2:R62"), 2, False) Then
                For j = LBound(arOne, 2) + 1 To UBound(arOne, 2)
                    If arOne(o, j) = Cells(I, 2).Value Then
                        Cells(I, 3).Value = arOne(o, 0)
                        ActiveSheet.Calculate
                        Erase arOne()
                            ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort.SortFields.Clear
                            ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort.SortFields.Add _
                            Key:=Range("Table1[[#All],[Random '#]]"), SortOn:=xlSortOnValues, Order:= _
                            xlDescending, DataOption:=xlSortTextAsNumbers
                        With ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort
                          .Header = xlYes
                          .MatchCase = False
                          .Orientation = xlTopToBottom
                          .SortMethod = xlPinYin
                          .Apply
                        End With
                        GoTo NextIR
                    End If
                Next j
            End If
        End If
    Next o


Next I

MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")

MsgBox "Assignments completed in " & MinutesElapsed & " minutes", vbInformation

End Sub

Answer 3

Не совсем уверен, что я правильно понял вашу настройку, но вы можете попробовать это:

Option Explicit

Sub Assign()

Randomize
Range("C2", Range("C" & Rows.Count).End(xlUp)).ClearContents

Dim R1 As Range: Set R1 = Range("L2:M920") 'People skill table
Dim R2 As Range: Set R2 = Range("A2:B612") 'Cusotmers skill talbe
Dim D0 As Object: Set D0 = CreateObject("scripting.dictionary")
Dim i As Integer, j As Integer, Rand as Integer

For i = 1 To R2.Rows.Count
    Rand = Int(R1.Rows.Count * Rnd + 1)
    For j = 1 To R1.Rows.Count
        If R1.Cells(Rand, 2) = R2(i, 2) And Not D0.exists(Rand) Then
            R2.Cells(i, 2).Offset(0, 1) = R1(Rand, 1)
            D0.Add Rand, Rand
            Exit For
        End If
        Rand = (Rand  Mod R1.Rows.Count) + 1
    Next j
Next i

End Sub  

Идея состоит в том, чтобы проверить людейсписок навыков, начиная со случайной точки и следя за тем, чтобы ключ не использовался дважды.

---

РЕДАКТИРОВАТЬ:

В соответствии с вашим комментарием, я предполагаю "люди /«умение» может быть назначено более одного раза, так как есть более 7000 клиентов?

Приведенный ниже код случайным образом назначает с довольно хорошим распределением 1500 человек на 7000 клиентов в +/- 1 секунду.

ЕстьПопробуйте и можете ли вы адаптировать его к вашему проекту.

Option Explicit

Sub Assign()
Application.ScreenUpdating = False
Dim Start: Start = Timer
Randomize
Range("C2:C99999").ClearContents

Dim D1 As Object
Dim R1 As Range: Set R1 = Range("L2", Range("M" & Rows.Count).End(xlUp))
Dim R2 As Range: Set R2 = Range("A2", Range("B" & Rows.Count).End(xlUp))
Dim T1: T1 = R1
Dim T2: T2 = R2
Dim T3()
Dim a As Integer: a = 1
Dim i As Integer, j As Integer, k As Integer, Rnd_Val As Integer, j_loop As Integer

For i = 1 To (Int(R2.Rows.Count / R1.Rows.Count) + 1)
    Set D1 = CreateObject("scripting.dictionary")
    For j = (R1.Rows.Count * i - R1.Rows.Count + 1) To R1.Rows.Count * i
        ReDim Preserve T3(1 To j)
        Rnd_Val = Int(Rnd * R1.Rows.Count + 1)
        For k = 1 To R1.Rows.Count
            If T1(Rnd_Val, 2) = T2(j, 2) And Not D1.exists(Rnd_Val) And T3(j) = "" Then
                T3(j) = T1(Rnd_Val, 1)
                D1.Add Rnd_Val, Rnd_Val
                Exit For
            End If
            Rnd_Val = (Rnd_Val Mod R1.Rows.Count) + 1
        Next k
        If T3(j) = "" Then
            For k = 1 To R1.Rows.Count
                If T1(Rnd_Val, 2) = T2(j, 2) Then
                    T3(j) = T1(Rnd_Val, 1)
                    Exit For
                End If
                Rnd_Val = (Rnd_Val Mod R1.Rows.Count) + 1
            Next k
        End If
        a = a + 1
        If a > R2.Rows.Count Then GoTo EndLoop
    Next j
    Set D1 = Nothing
Next i

EndLoop:
Range("C2").Resize(UBound(T3), 1) = Application.Transpose(T3)
Debug.Print Timer - Start
Application.ScreenUpdating = True
End Sub