如何用VB实现分组的随机抽样

Sub RandomSampleByWarehouseSimple()
    Dim wsSource As Worksheet, wsDest As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim dict As Object
    Dim i As Long, j As Long, k As Long
    Dim warehouseCol As Long, sampleSize As Integer
    Dim warehouseName As String
   
    ' 设置参数
    Set wsSource = ThisWorkbook.Worksheets("9.15")
    sampleSize = 5
    warehouseCol = 42 ' B列
    lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
    lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
   
    ' 创建目标工作表
    On Error Resume Next
    Application.DisplayAlerts = False
    ThisWorkbook.Worksheets("抽样结果").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
   
    Set wsDest = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
    wsDest.Name = "抽样结果"
   
    ' 复制表头
    wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(1, lastCol)).Copy wsDest.Range("A1")
   
    ' 使用字典存储行号
    Set dict = CreateObject("Scripting.Dictionary")
   
    For i = 2 To lastRow
        warehouseName = wsSource.Cells(i, warehouseCol).Value
        If Not dict.Exists(warehouseName) Then
            Set dict(warehouseName) = New Collection
        End If
        dict(warehouseName).Add i
    Next i
   
    Application.ScreenUpdating = False
   
    ' 随机抽样并复制
    Dim destRow As Long: destRow = 2
    For Each Key In dict.Keys
        Dim arr() As Long
        Dim n As Long: n = dict(Key).Count
        ReDim arr(1 To n)
        
        For k = 1 To n
            arr(k) = dict(Key)(k)
        Next k
        
        ' 随机排序
        Randomize
        For k = n To 2 Step -1
            Dim randIndex As Long: randIndex = Int(Rnd * k) + 1
            Dim temp As Long: temp = arr(k)
            arr(k) = arr(randIndex)
            arr(randIndex) = temp
        Next k
        
        ' 复制数据
        Dim actualSample As Long: actualSample = WorksheetFunction.Min(sampleSize, n)
        For k = 1 To actualSample
            For j = 1 To lastCol
                wsDest.Cells(destRow, j).Value = wsSource.Cells(arr(k), j).Value
            Next j
            destRow = destRow + 1
        Next k
    Next Key
   
    ' 转换为Table
    Dim tbl As ListObject
    Set tbl = wsDest.ListObjects.Add(xlSrcRange, wsDest.Range("A1").CurrentRegion, , xlYes)
    tbl.Name = "RandomSampleResults"
    tbl.TableStyle = "TableStyleMedium2"
   
    wsDest.Columns.AutoFit
    Application.ScreenUpdating = True
   
End Sub