根据多个条件在VBA中将随机的唯一行从一张纸复制到另一张纸

Question

我希望从名为"Master"的工作表中随机复制 70 行，并根据 S 列为"FTF"将这 70 行复制到名为"Checks"的工作表中，随机拆分需要为 65，其中 AT 列 = "ASL"，5 列 AT = "客户"。我需要复制的行满足上述条件，但也是唯一的，所以如果它尝试在同一行上复制两次，它将跳过它。

"主"表的列一直到 BR，但我只想跨从 P 开始到 BR 结束的列进行复制。

到目前为止，我拥有的代码似乎正在复制 70 个值，如下所示，但它带来了所有行，而不管 S 列中的内容如何，这就是我需要的其他条件：

Sub MattWilliams()
Dim rawDataWs As Worksheet, randomSampleWs As Worksheet
Dim map, i As Long, n As Long, c As Long, rand, col
Dim rng As Range
Dim keyArr, nRowsArr
Set rawDataWs = Worksheets("Master")
Set randomSampleWs = Worksheets("Checks")
randomSampleWs.UsedRange.ClearContents
'EDIT: dynamic range in ColA
Set rng = rawDataWs.Range("AT9:AT" & rawDataWs.Cells(Rows.Count, 1).End(xlUp).Row)
Set map = RowMap(rng)
keyArr = Array("ALS", "Customer") '<== keywords
nRowsArr = Array(65, 5) '<== # of random rows
Debug.Print "Key", "#", "Row#"
For i = LBound(keyArr) To UBound(keyArr)
If map.exists(keyArr(i)) Then
Set col = map(keyArr(i))
n = nRowsArr(i)
For c = 1 To n
'select a random member of the collection
rand = Application.Evaluate("RANDBETWEEN(1," & col.Count & ")")
Debug.Print keyArr(i), rand, col(rand)
rawDataWs.Rows(col(rand)).Copy _
randomSampleWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
'col.Remove rand 'remove the "used" row
If col.Count = 0 Then
If c < n Then Debug.Print "Not enough rows for " & keyArr(i)
Exit For
End If
Next c
Else
Debug.Print "No rows for " & keyArr(i)
End If
Next i
End Sub
'get a map of rows as a dictionary where each value is a collection of row  numbers
Function RowMap(rng As Range) As Object
Dim dict, c As Range, k
Set dict = CreateObject("scripting.dictionary")
For Each c In rng.Cells
k = Trim(c.Value)
If Len(k) > 0 Then
If Not dict.exists(k) Then dict.Add k, New Collection
dict(k).Add c.Row
End If
Next c
Set RowMap = dict
End Function

我需要一些帮助来修改上面的代码，以便根据我的条件仅跨行复制，但我正在努力了解如何修改代码。

感谢您提供任何帮助，只是试图知道我哪里出了问题，或者我如何解决如何修改上面的 VBA 代码。我尝试在论坛上搜索，但没有什么是我正在寻找的，也没有帮助我确定我出错的地方。

谢谢

马 特

Answer 1

编辑：

下面是完整的代码。忽略我之前发布的答案...只需要对 RowMap 函数进行一个小改动(还更改了一些变量名称，希望没什么大不了的(

Option Explicit
Sub MattWilliams()
Dim rawDataWs As Worksheet, randomSampleWs As Worksheet
Dim map, i As Long, n As Long, counter As Long, rand, col
Dim rng As Range
Dim keyArr, nRowsArr
Set rawDataWs = ThisWorkbook.Worksheets("Master")
Set randomSampleWs = ThisWorkbook.Worksheets("Checks")
randomSampleWs.UsedRange.ClearContents
'EDIT: dynamic range in ColA
Set rng = rawDataWs.Range("AT9:AT" & rawDataWs.Cells(Rows.Count, 1).End(xlUp).Row)
Set map = RowMap(rng, rawDataWs)
keyArr = Array("ALS", "Customer") '<== keywords
nRowsArr = Array(65, 5) '<== # of random rows
Debug.Print "Key", "#", "Row#"
For i = LBound(keyArr) To UBound(keyArr)
If map.exists(keyArr(i)) Then
Set col = map(keyArr(i))
n = nRowsArr(i)
For counter = 1 To n
'select a random member of the collection
rand = Application.Evaluate("RANDBETWEEN(1," & col.Count & ")")
Debug.Print keyArr(i), rand, col(rand)
rawDataWs.Rows(col(rand)).Copy _
randomSampleWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
col.Remove rand 'remove the "used" row
If col.Count = 0 Then
If counter < n Then Debug.Print "Not enough rows for " & keyArr(i)
Exit For
End If
Next counter
Else
Debug.Print "No rows for " & keyArr(i)
End If
Next i
End Sub
'get a map of rows as a dictionary where each value is a collection of row  numbers
Function RowMap(rng As Range, rawDataWs As Worksheet) As Object
Dim dict, cell As Range, cellValue
Set dict = CreateObject("scripting.dictionary")
' "ALS" or "Customer"
For Each cell In rng.Cells
cellValue = Trim(cell.Value)
If Len(cellValue) > 0 Then
If (Not dict.exists(cellValue)) And rawDataWs.Range("S" & cell.Row).Value = "FTF" Then
dict.Add cellValue, New Collection
dict(cellValue).Add cell.Row
ElseIf rawDataWs.Range("S" & cell.Row).Value = "FTF" Then
dict(cellValue).Add cell.Row
End If
End If
Next cell
Set RowMap = dict
End Function