Help with VBA that copies % of random rows to new sheet.

[Serafin54]

Hello,

I have the vba below that works fine to copy 10% to a new sheet for auditing various ranges of data. I am hoping to see if there is a way to tweak the code to make it even better though. What I am curious to see is how to:

1. Speed up the vba. Though it runs fine, on 70k rows, it seems to hang. It's not a game killer but I suspect there is something I'm unaware of.
2. I would like the sheet to be automatically renamed "Audit - " & whatever the source sheet name. When I update the Set Target to match the concatenate of the Add piece of code, I get a debug error so I'm obviously wrong with that.
3. if at all possible, to loop through each worksheet rather than running each sheet one by one. This one is quite a stretch and I believe that if this were in place, #1 would remain slow.

thanks to all, ahead of time.

Sub AuditRange()

Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual

    Dim Pct As Long
    Dim CntRow As Long
    Dim Rw As Long
    Dim Source As Worksheet
    Dim Target As Worksheet

    Set Source = ActiveSheet
    CntRow = Cells.Find("*", after:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Audit"
    Set Target = Sheets("Audit")
    Source.Rows(1).Copy Target.Range("A1")
    Pct = Int(0.1 * CntRow)
    If Pct > 100 Then Pct = 100
    
    
    Do While Pct > 0
        Rw = WorksheetFunction.RandBetween(2, CntRow)
        Source.Rows(Rw).Copy Target.Range("A" & Rows.Count).End(xlUp).Offset(1)
        Pct = Pct - 1
    Loop
      
  Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

 

[DanteAmor]

Hello @Serafin54 , I hope you are well.

I did a test with 4 sheets, each sheet with 70k records, the macro processed all 4 sheets in a second.

Sub audit_rows()
  Dim sh As Worksheet
  Dim sName As String
  Dim a() As Variant, arr As Variant
  Dim i&, j&, lr As Long, lc As Long, pct As Long
  Dim m&, x&, y&, z&
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Randomize
  
  For Each sh In Sheets
    lr = sh.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
    lc = sh.Cells.Find("*", , xlValues, xlPart, xlByColumns, xlPrevious).Column
    Erase a
    a = sh.Range("A1", sh.Cells(lr, lc)).Value
        
    pct = Int(lr * 0.1)
    If pct > 100 Then pct = 100
    
    ReDim b(1 To pct + 1, 1 To UBound(a, 2))
    For j = 1 To UBound(a, 2)
      b(1, j) = a(1, j)
    Next
      
    i = 1
    lr = lr - 1
    arr = Evaluate("ROW(1:" & lr & ")")   'total records
    For z = 1 To pct                      'how many do i want
      x = Int(Rnd * lr + z)
      y = arr(z, 1)
      arr(z, 1) = arr(x, 1)
      arr(x, 1) = y
      lr = lr - 1
      m = arr(z, 1)                       'random number
      i = i + 1
      
      For j = 1 To UBound(a, 2)
        b(i, j) = a(m, j)
      Next
    Next

    sName = "Audit - " & sh.Name
    On Error Resume Next: Sheets(sName).Delete: On Error GoTo 0
    Sheets.Add(after:=Sheets(Sheets.Count)).Name = sName
    ActiveSheet.Range("A1").Resize(UBound(b, 1), UBound(b, 2)).Value = b
  Next

  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

Comment how many sheets you have, how many records on average per sheet, and how long the macro took.

Cordially
Dante Amor
--------------

 

[Serafin54]

Hello @Serafin54 , I hope you are well.

I did a test with 4 sheets, each sheet with 70k records, the macro processed all 4 sheets in a second.

Sub audit_rows()
  Dim sh As Worksheet
  Dim sName As String
  Dim a() As Variant, arr As Variant
  Dim i&, j&, lr As Long, lc As Long, pct As Long
  Dim m&, x&, y&, z&
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Randomize
 
  For Each sh In Sheets
    lr = sh.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
    lc = sh.Cells.Find("*", , xlValues, xlPart, xlByColumns, xlPrevious).Column
    Erase a
    a = sh.Range("A1", sh.Cells(lr, lc)).Value
       
    pct = Int(lr * 0.1)
    If pct > 100 Then pct = 100
   
    ReDim b(1 To pct + 1, 1 To UBound(a, 2))
    For j = 1 To UBound(a, 2)
      b(1, j) = a(1, j)
    Next
     
    i = 1
    lr = lr - 1
    arr = Evaluate("ROW(1:" & lr & ")")   'total records
    For z = 1 To pct                      'how many do i want
      x = Int(Rnd * lr + z)
      y = arr(z, 1)
      arr(z, 1) = arr(x, 1)
      arr(x, 1) = y
      lr = lr - 1
      m = arr(z, 1)                       'random number
      i = i + 1
     
      For j = 1 To UBound(a, 2)
        b(i, j) = a(m, j)
      Next
    Next

    sName = "Audit - " & sh.Name
    On Error Resume Next: Sheets(sName).Delete: On Error GoTo 0
    Sheets.Add(after:=Sheets(Sheets.Count)).Name = sName
    ActiveSheet.Range("A1").Resize(UBound(b, 1), UBound(b, 2)).Value = b
  Next

  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

Comment how many sheets you have, how many records on average per sheet, and how long the macro took.

Cordially
Dante Amor
--------------

This is a thing of beauty. Thank you very much Dante

 

[Serafin54]

Hello @Serafin54 , I hope you are well.

I did a test with 4 sheets, each sheet with 70k records, the macro processed all 4 sheets in a second.

Sub audit_rows()
  Dim sh As Worksheet
  Dim sName As String
  Dim a() As Variant, arr As Variant
  Dim i&, j&, lr As Long, lc As Long, pct As Long
  Dim m&, x&, y&, z&
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Randomize
 
  For Each sh In Sheets
    lr = sh.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
    lc = sh.Cells.Find("*", , xlValues, xlPart, xlByColumns, xlPrevious).Column
    Erase a
    a = sh.Range("A1", sh.Cells(lr, lc)).Value
       
    pct = Int(lr * 0.1)
    If pct > 100 Then pct = 100
   
    ReDim b(1 To pct + 1, 1 To UBound(a, 2))
    For j = 1 To UBound(a, 2)
      b(1, j) = a(1, j)
    Next
     
    i = 1
    lr = lr - 1
    arr = Evaluate("ROW(1:" & lr & ")")   'total records
    For z = 1 To pct                      'how many do i want
      x = Int(Rnd * lr + z)
      y = arr(z, 1)
      arr(z, 1) = arr(x, 1)
      arr(x, 1) = y
      lr = lr - 1
      m = arr(z, 1)                       'random number
      i = i + 1
     
      For j = 1 To UBound(a, 2)
        b(i, j) = a(m, j)
      Next
    Next

    sName = "Audit - " & sh.Name
    On Error Resume Next: Sheets(sName).Delete: On Error GoTo 0
    Sheets.Add(after:=Sheets(Sheets.Count)).Name = sName
    ActiveSheet.Range("A1").Resize(UBound(b, 1), UBound(b, 2)).Value = b
  Next

  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

Comment how many sheets you have, how many records on average per sheet, and how long the macro took.

Cordially
Dante Amor
--------------

If I wanted this to run only on the sheets that a user selects, say just the one active or if they CTRL Shift selected a couple individual sheets, would I just alter the For Each sh In Sheets line?

 

[DanteAmor]

Change this:

For Each sh In Sheets

For this:

For Each sh In ActiveWindow.SelectedSheets

 

[Serafin54]

Change this:

For Each sh In Sheets

For this:

For Each sh In ActiveWindow.SelectedSheets

Thank you.