Option Compare Text
Sub random10()
Dim a(), iSh, DC()
t = Timer
Set dict = CreateObject("scripting.dictionary") 'dictionary that collects all your data
For iSh = 1 To 5 'loop first 5 worksheets
Set sh = ThisWorkbook.Worksheets(iSh)
With sh
Set c = .UsedRange.Columns(1).SpecialCells(xlConstants) 'the cells filled with data in the 1st column of the usedrange
If c.Areas.Count > 1 Then MsgBox "their addresses are " & c.Address, vbInformation, UCase("multiple areas in " & .Name)
If c.Cells(1).Address <> "$A$1" Then MsgBox "no data in A1", vbInformation, UCase(.Name)
ll = c.Areas(1).Rows.Count - 2 'the first area minus A1:A2
If ll < 1 Then GoTo volgende
arr = c.Areas(1).Offset(2).Resize(ll, 5).Value2 'read 5 columns to array
End With
seq = Evaluate("transpose(row(A1:A" & ll & "))") 'hopefully your last line < 65.000 (problem with the transpose)
If UBound(arr) > UBound(seq) Then MsgBox "problem, sheet " & sh.Name & " oversized"
ptr = 0 'reset pointer
'we want to random pick a row, but if that row wasn't okay, later never pick it again !!!!
For i = UBound(seq) To 1 Step -1 'in the 1st loop, you can choose all the numbers, 2nd loop = 1 less, etc
r0 = Application.RandBetween(1, i) 'random number between 1 and the actual max
r = seq(r0)
If Len(arr(r, 1)) > 0 Then 'there was data in that cell
ReDim a(1 To 5) 'of this line we reserve 5 elements to be added to the dictionary
For j = 1 To 5 'in a loop copy the other cells in that same row
a(j) = arr(r, j)
Next
dict.Add dict.Count, a 'add to dictionary
ptr = ptr + 1 'increment pointer
If ptr >= UBound(arr) * 0.1 Then Exit For '10% achieved : YOU CAN MODIFY THIS TO 0.99 AND CHECK IF THERE ARE NO DUPLICATES IN THE TABLE
End If
seq(r0) = seq(i) 'move the last number of that loop to the position of r0, so every row 'll only be used once !! <<< VERY IMPORTANT ROW !!!!!
Next
volgende:
Next
If dict.Count Then
arr = Application.Index(dict.items, 0, 0)
seq = Evaluate("transpose(row(A1:A" & UBound(arr) & "))") 'hopefully your last line < 65.000 (problem with the transpose)
ReDim DC(1 To 1, 1 To 1)
ReDim DC(1 To WorksheetFunction.RoundUp(UBound(arr) * 0.1, 0), 1 To 1)
ptr = 0 'reset pointer
'we want to random pick a row, but if that row wasn't okay, later never pick it again !!!!
For i = UBound(seq) To 1 Step -1 'in the 1st loop, you can choose all the numbers, 2nd loop = 1 less, etc
r0 = Application.RandBetween(1, i) 'random number between 1 and the actual max
r = seq(r0)
If Len(arr(r, 1)) > 0 Then 'there was data in that cell
ptr = ptr + 1
DC(ptr, 1) = r
If ptr >= UBound(DC) Then Exit For '10% achieved : YOU CAN MODIFY THIS TO 0.99 AND CHECK IF THERE ARE NO DUPLICATES IN THE TABLE
End If
seq(r0) = seq(i) 'move the last number of that loop to the position of r0, so every row 'll only be used once !! <<< VERY IMPORTANT ROW !!!!!
Next
With Worksheets("level 1 Check").Range("A" & Rows.Count).End(xlUp).Offset(2).Resize(dict.Count, UBound(a))
.Value = Application.Index(dict.items, 0, 0)
MyLayout .Offset(0)
End With
seq = Evaluate("transpose(row(A1:A" & UBound(a) + 1 & "))") 'hopefully your last line < 65.000 (problem with the transpose)
With Worksheets("Level 2 Check").Range("A" & Rows.Count).End(xlUp).Offset(2).Resize(UBound(DC), UBound(a))
.Value = Application.Index(dict.items, DC, seq)
MyLayout .Offset(0)
End With
End If
Application.CutCopyMode = False
MsgBox "Ready in " & Format(Timer - t, "0.00\s"), vbInformation, UCase("Statistics")
End Sub
Sub MyLayout(MyRange)
With MyRange
With .Font
.Name = "Calibri" 'or another font
.FontStyle = "General" 'i hope this is the correct term in english (???)
.Size = 12
End With
.Offset(, .Columns.Count - 2).Resize(, 2).NumberFormat = "dd/mm/yy"
.HorizontalAlignment = xlCenter
With .Borders
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End With
End Sub
