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

debugcn 发表于 Dev

马特·威廉姆斯

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

“主”表的列一直到 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 代码的修改方法。我试过在论坛上搜索，但没有什么是我正在寻找的，也没有帮助我确定我哪里出错了。

谢谢

马特

古巴

编辑：

这是完整的代码。忽略我之前发布的答案...只需要对 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

本文收集自互联网，转载请注明来源。

如有侵权，请联系[email protected] 删除。