宏为审计目的做随机分配

Question

有人可以帮我根据以下要求创建宏吗？

我每天都会收到生产团队的生产文件，生产数量可能会根据库存而变化。

员工总数：300，他们生产5000条记录意味着我需要根据％来随机选择行。

例如，如果我收到包含5000行的生产文件，则意味着我需要为进行随机审核分配一定的50％或60％或70％。 （％也根据审计员的数量而有所不同）。随机选择应涵盖所有在场的员工。

Answer 1

假设5000条记录位于数据工作表上。在名为 Picks 的单独工作表上，通过 A5000 填充 A1 1到5000.填写 B1 至 B5000 具有以下功能：

=RAND()

然后按 B 对cols A 和 B 进行排序：

现在你有一个随机选择列表。

1. 50％使用第1至2500行
2. 60％使用第1至3000行
3. 70％使用第1至3500行

修改＃1：

此宏似乎可以执行您想要的操作：

Sub ytrewq()
    Dim A As Range, B As Range, AB As Range

    Set A = Range("A1:A5000")
    Set B = Range("B1:B5000")
    Set AB = Union(A, B)

    A.Formula = "=row()"
    B.Formula = "=rand()"
    AB.Value = AB.Value

    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=B, SortOn:=xlSortOnValues, _
            Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange AB
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Answer 2

Option Explicit

Sub kTest()

Dim k, kk, kkk(), dic As Object, i As Long, t
Dim r As Long, j As Long, n As Long, p As Long
Dim ls As String

With Sheets("Summary").Range("XFA6")

        If Not IsDate(.Value) Then
           MsgBox "No date"
        Exit Sub
        ElseIf .Value < Date Then
            MsgBox "MIS"
        Exit Sub

        Else
        End If

    End With

ls = Worksheets("Summary").Range("E14").Value

Set dic = CreateObject("scripting.dictionary")
dic.comparemode = 1

With Worksheets("Source")
k = .Range("a1").CurrentRegion.Value2
End With

For i = 2 To UBound(k, 1)
If Len(k(i, 1)) Then
t = dic.Item(k(i, 1))
If IsEmpty(t) Then
dic.Item(k(i, 1)) = Array(1, i)
Else
t(0) = t(0) + 1
t(1) = t(1) & "|" & i
dic.Item(k(i, 1)) = t
End If
End If
Next

kk = Array(dic.keys, dic.items)
ReDim kkk(1 To UBound(k, 1), 1 To UBound(k, 2))

For i = 0 To UBound(kk(0))
p = kk(1)(i)(0) * ls
t = Split(kk(1)(i)(1), "|")
dic.RemoveAll
j = 1
Do While j <= p
r = Application.WorksheetFunction.RandBetween(1, UBound(t) + 1) - 1
If Not dic.exists(r) Then
dic.Item(r) = Empty
n = n + 1
kkk(n, 1) = k(t(r), 1)
kkk(n, 2) = k(t(r), 2)

j = j + 1
End If
Loop
Next

If n Then
With Worksheets("Audit")
.[A1].CurrentRegion.Offset(1).ClearContents
.[a2].Resize(n, 2).Value = kkk
End With
End If
End Sub