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。（如果有用，请删除upvote）

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。

Excel VBA：将唯一行从一张纸复制到另一张纸

1 个答案: