Question

我有一个以下脚本，将具有已知技能的人员列表排列在一个数组中，然后将第一个匹配项与具有相同技能的客户匹配。每次运行时结果都是相同的。我想让它成为数组的随机顺序，但将数组中的两列保持在一起。如何改组（重新排列）数组，使数组中的行保持相同？还是最好删除阵列，对列进行随机排序并备份阵列？

/etc/php/7.2/apache2/php.ini

Answer 1

不能完全确定我的设置正确无误，但是您可以尝试以下方法：

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多个客户，那么可以多次分配“人/技能”？

下面的代码在+/- 1秒内向7000个客户随机分配了1500个人。

尝试一下，看看是否可以将其适应您的项目。

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

Answer 2

多个循环和对范围对象的多次访问使您的代码非常非常慢（我不知道性能是否很重要）。

我将所有必要的数据读取到数组，并使用filter和rnd来获得具有相关技能的随机人：

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 3

通过根据表中的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

如何在VBA中随机播放2D数组？

3 个答案: