Question

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

“主”页面的所有列一直到BR，但我只希望t跨列复制，从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

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

1 个答案: