vba - Excel VBA : Copying across unique rows from one sheet to another

Question

我正在尝试将基于某些标准随机选择的 70 行复制到另一张工作表，但确保一旦复制到第二张工作表中仅存在 70 个唯一行。

我下面的代码根据所需条件正确复制了 70 行，但它也在复制重复行，因为如果数组中有重复值，则没有逻辑选择另一行。

如果该行已存在于数组中，任何有关修改代码以选择另一行的帮助将不胜感激。

我想我需要存储随机选择的行，然后检查下一个选择的行是否不在该数组中，否则选择另一行？

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) 'loops through lower and upper bound of the 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)

            If rawDataWs.Range("S" & col(rand)).Value = "FTF" Then

                 rawDataWs.Rows(col(rand)).Copy _
        randomSampleWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    If col.Count = 0 Then
        If c < n Then Debug.Print "Not enough rows for " & keyArr(i)
        c = c - 1
    End If

Else
    c = c - 1


            End If
                'col.Remove rand 'remove the "used" row
                If col.Count = 0 Then
                    If c < n Then Debug.Print "Not enough rows for " & keyArr(i)

                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

如果您需要更多信息，请告诉我

问候，

马特

Answer 1

您需要使用一组唯一随机数来确保它们不相同。唯一随机数功能可查看here . (如果有用请点赞)

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
    Dim samplepattern() As Long ' dim the samplepattern

    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) 'loops through lower and upper bound of the KeyArr
        If map.exists(keyArr(i)) Then

            Set col = map(keyArr(i))
            n = nRowsArr(i)
            '''''''''''''''''''''''''''''''''''''''''
            'solution starts here
            samplepattern = UniuqeRandom(1, col.Count,n) 'see link "here"

            For c = 1 To n
                Debug.Print keyArr(i), samplepattern(n), col(rand)

            If rawDataWs.Range("S" & col(samplepattern(n))).Value = "FTF" Then

                 rawDataWs.Rows(col(samplepattern(n))).Copy _
        randomSampleWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        ' end of solution
        '''''''''''''''''''''''''''''''''''''''
    If col.Count = 0 Then
        If c < n Then Debug.Print "Not enough rows for " & keyArr(i)
        c = c - 1
    End If

Else
    c = c - 1


            End If
                'col.Remove rand 'remove the "used" row
                If col.Count = 0 Then
                    If c < n Then Debug.Print "Not enough rows for " & keyArr(i)

                End If
            Next c

        Else
            Debug.Print "No rows for " & keyArr(i)
        End If
    Next i
End Sub

所以基本上你会得到一组随机数，所有这些都是事先唯一的。然后循环遍历集合并复制该集合中包含的所有行号。

示例:samplepattern() = [2,3,7,17​​] 是 1 到 20 之间的 4 个唯一随机数。现在我继续遍历 samplepattern() 的所有成员并复制行 (samplepattern(i))。所以我复制了第 2、3、7 和 17 行。