Random Data: wanted result2 not duplicate with result1

[Sophanith]

Dear Expert,

We have a problem on how to make random capture data without the duplicate for the new result with the code below. For the detail, you can find the excel as in attached file.

Sub sub_random()

Dim wbD As Workbook
Dim wsD As Worksheet
Dim wsR As Worksheet

Dim nber_rows As Long
Dim sample As Long
Dim alea As Long

Dim i As Long, j As Long, k As Long

Set wbD = ThisWorkbook

Set wsD = wbD.Worksheets("Sheet1")
nber_rows = wsD.Cells(4, 3).Value
Set wsR = wbD.Worksheets.Add
wsR.Move After:=wbD.Worksheets("Sheet1")
wsR.Name = "RenamePlease"

wsR.Cells(1, 1).Resize(1, 6).Value = wsD.Cells(9, 1).Resize(1, 6).Value
wsR.Cells(1, 1).Resize(1, 6).Interior.Color = RGB(221, 235, 247)

sample = WorksheetFunction.RoundUp(nber_rows * 0.5, 0)

Randomize

i = Int((nber_rows - 1 + 1) * Rnd + 10)
wsR.Cells(2, 1).Resize(1, 6).Value = wsD.Cells(i, 1).Resize(1, 6).Value

For j = 2 To sample
i = Int((nber_rows - 1 + 1) * Rnd + 10)
wsR.Cells(j + 1, 1).Resize(1, 6).Value = wsD.Cells(i, 1).Resize(1, 6).Value

For k = 1 To j - 1
    While wsR.Cells(j + 1, 4).Value = wsR.Cells(k + 1, 4).Value
        i = Int((nber_rows - 1 + 1) * Rnd + 10)
        wsR.Cells(j + 1, 1).Resize(1, 6).Value = wsD.Cells(i, 1).Resize(1, 6).Value
    Wend
Next k
Next j

Columns.AutoFit
End Sub

----
Thank for your help

Phanith

 

[Marc L]

Hi !​

​

After editing your initial post and adding the code tags (or just using the code icon within the 3 dots icon)​

crystal clear explain your random context ! Maybe the easy way is permutations within an array …​

​

 

[p45cal]

Have you considered randomly sorting the data on Sheet1 (you can add a column of random numbers then sort on that), then taking successive slices of 20 rows of data from the top (or bottom)?
You could make a copy of Sheet1, do the random sorting on it once, then take the bottom 20 rows and move them (rather than copy them so that they disappear from that sheet) to your new result sheet. Then when you want your next set of random rows, take the next bottom 20 rows etc.

 

[Marc L]

For the detail, you can find the excel as in attached file.

According to your attachment the easy way is an array with permutations (swaps)​

without any helper column like column G (so delete this column !) …​

​

A starter demonstration (Edit : v2 as more universal !) :​

Sub Demo2()
        Dim V, M&, N&, R&
            Application.ScreenUpdating = False
            Sheet19.UsedRange.Offset(1).Clear
            Randomize
    With Sheet1.[A9].CurrentRegion.Rows
            V = Evaluate("ROW(2:" & .Count & ")")
            M = UBound(V) \ 2
        For N = UBound(V) To M + 1 Step -1
            R = Fix(Rnd * N) + 1
           .Item(V(R, 1)).Copy Sheet19.Cells(N - M + 1, 1)
            V(R, 1) = V(N, 1)
        Next
            Sheet18.UsedRange.Offset(1).Clear
            For R = 1 To M:  .Item(V(R, 1)).Copy Sheet18.Cells(R + 1, 1):  Next
    End With
            Application.ScreenUpdating = True
End Sub

Do you like it ? So thanks to click on bottom right Like !​

​

 

[Sophanith]

Dear Marc,

Do we have the way to put the percentage on your coding? example: if we just want to get only 10% of the data and it pop up to another sheet every running coding.

Sorry for disturb you.

Phanith

 

[Marc L]

It was just a demonstration to reproduce the expected result according to your attachment :​

random data between two sheets without duplicate …​

​

For your new need you can adapt this swaps array way to draw only the desired number of data.​

​