Need a macro to do a random 10% Audit

Hello,

I need assistance in creating a macro that will randomly select 10% of information on Sheet 1(Log) and copy the information to Sheet 4 (Audit). The information on Sheet 1 starts in row 9 due to information for data validation being housed in lines 1-8. I tried searching online for different macros and wasn't successful in finding one that will work with minor tweaks.

Thank you for your assistance.

Sub ciresuark()

Set ws1 = Sheets("Log")
Set ws2 = Sheets("Audit")
OpenRow = 9
LastRow = ws1.Cells(Rows.Count, "A").End(xlUp).Row
CRows = Round((LastRow - 8) * 0.1)

For i = 1 To CRows
    Do
        CRow = CInt(Rnd() * LastRow)
    Loop Until CRow > 8
    ws1.Rows(CRow).EntireRow.Copy ws2.Rows(OpenRow)
    OpenRow = OpenRow + 1
Next

End Sub

That is perfect! Thank you so much for your help!

What was previously supplied is awesome. Is it possible to add to it an option to do a 10% audit for a name in cell A1, then do a 10% audit for the name in cell A2? The results of the would be in order on the following page. Thoughts?

10% each of the total number of names, or 10% each for each name?

If example if you had 100 Lisas and 200 Bobs, would you want:

1. 30 Lisas and 30 Bobs, or
2. 10 Lisas and 20 Bobs

10 Lisas and 20 Bobs. So 10% for each name.

Got it. See code below.

Note: This assumes that the names for each row are also listed in column A. I don't think you specified where they are in each row.

Sub ciresuark2()
Set ws1 = Sheets("Log")
Set ws2 = Sheets("Audit")

OpenRow = 9
LastRow = ws1.Cells(Rows.Count, "A").End(xlUp).Row

With ws1.Range("A9:A" & LastRow)
Set c = .Find(ws1.Range("A1").Value, lookat:=xlWhole)
If Not c Is Nothing Then
    FirstAdd = c.Address
    Do
    n1 = n1 + 1
    Set c = .FindNext(c)
    Loop While Not c Is Nothing And c.Address <> FirstAdd
End If

Set c = .Find(ws1.Range("A2").Value, lookat:=xlWhole)
If Not c Is Nothing Then
    FirstAdd = c.Address
    Do
    n2 = n2 + 1
    Set c = .FindNext(c)
    Loop While Not c Is Nothing And c.Address <> FirstAdd
End If

End With
    

CRows1 = Round((n1) * 0.1)
CRows2 = Round((n2) * 0.1)

i = 0
Do
    Do
        CRow = CInt(Rnd() * LastRow)
    Loop Until CRow > 8
    If ws1.Range("A" & CRow).Value = ws1.Range("A1").Value Then
        ws1.Rows(CRow).EntireRow.Copy ws2.Rows(OpenRow)
        OpenRow = OpenRow + 1
        i = i + 1
    End If
Loop Until i = CRows1

i = 0
Do
    Do
        CRow = CInt(Rnd() * LastRow)
    Loop Until CRow > 8
    If ws1.Range("A" & CRow).Value = ws1.Range("A2").Value Then
        ws1.Rows(CRow).EntireRow.Copy ws2.Rows(OpenRow)
        OpenRow = OpenRow + 1
        i = i + 1
    End If
Loop Until i = CRows2

End Sub

Sorry. I thought about that before I went to a meeting. The names for the audit are in row G.

Adjusted accordingly.

Sub ciresuark2()
Set ws1 = Sheets("Log")
Set ws2 = Sheets("Audit")

OpenRow = 9
LastRow = ws1.Cells(Rows.Count, "G").End(xlUp).Row

With ws1.Range("G9:G" & LastRow)
Set c = .Find(ws1.Range("A1").Value, lookat:=xlWhole)
If Not c Is Nothing Then
    FirstAdd = c.Address
    Do
    n1 = n1 + 1
    Set c = .FindNext(c)
    Loop While Not c Is Nothing And c.Address <> FirstAdd
End If

Set c = .Find(ws1.Range("A2").Value, lookat:=xlWhole)
If Not c Is Nothing Then
    FirstAdd = c.Address
    Do
    n2 = n2 + 1
    Set c = .FindNext(c)
    Loop While Not c Is Nothing And c.Address <> FirstAdd
End If

End With
    

CRows1 = Round((n1) * 0.1)
CRows2 = Round((n2) * 0.1)

i = 0
Do
    Do
        CRow = CInt(Rnd() * LastRow)
    Loop Until CRow > 8
    If ws1.Range("G" & CRow).Value = ws1.Range("A1").Value Then
        ws1.Rows(CRow).EntireRow.Copy ws2.Rows(OpenRow)
        OpenRow = OpenRow + 1
        i = i + 1
    End If
Loop Until i = CRows1

i = 0
Do
    Do
        CRow = CInt(Rnd() * LastRow)
    Loop Until CRow > 8
    If ws1.Range("G" & CRow).Value = ws1.Range("A2").Value Then
        ws1.Rows(CRow).EntireRow.Copy ws2.Rows(OpenRow)
        OpenRow = OpenRow + 1
        i = i + 1
    End If
Loop Until i = CRows2

End Sub

Thank you for your help. It works great. One scenario I am thinking of is if a person only has 9 entries it won't pull any data to audit until they have 10. Would it be easy to code to have it pull a minimum of 1 if the number is less than 10%?

Sure, Change your CRows1 = and CRows2 = lines to:

CRows1 = Application.WorksheetFunction.RoundUp(n1 * 0.1, 0)
CRows2 = Application.WorksheetFunction.RoundUp(n2 * 0.1, 0)

Awesome. That worked. Thank you again for your help!

what would be the code if selection criteria is based on value