循环筛选

彭庆伟

总公司下达抽检任务，需要在10000个销售单据里面，涉及100多个仓库，对每个仓库指定抽检单量，将筛选后的数据下发给各仓库，提前准备样本，单据较多，非常耗时，想通过VBA去实现结果，求大神指定迷津。

高个子

。。。貌似有点难度

3190496160

Sub 抽取数据()
Application.ScreenUpdating = False
Dim ar As Variant
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With ActiveSheet
    r = .Cells(Rows.Count, 4).End(xlUp).Row
    If r < 5 Then MsgBox "数据源为空！": End
    ar = .Range("d4:g" & r)
End With
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
For i = 2 To UBound(ar)
    If Trim(ar(i, 3)) <> "" Then
        d(Trim(ar(i, 3))) = ar(i, 1)
    End If
Next i
For Each k In d.keys
    n = 0
    ReDim cr(1 To UBound(ar), 1 To UBound(ar, 2))
    For i = 2 To UBound(ar)
        If Trim(ar(i, 3)) = k Then
            n = n + 1
            For j = 1 To UBound(ar, 2)
                cr(n, j) = ar(i, j)
            Next j
        End If
    Next i
    For i = 1 To n
        For s = i + 1 To n
            If cr(i, 3) > cr(s, 3) Then
                For j = 1 To UBound(cr, 2)
                    kk = cr(i, j)
                    cr(i, j) = cr(s, j)
                    cr(s, j) = kk
                Next j
            End If
        Next s
    Next i
    sl = d(k)
    For i = 1 To sl
        m = m + 1
        For j = 1 To UBound(cr, 2)
            br(m, j) = cr(i, j)
        Next j
    Next i
Next k
With Sheets("抽检结果")
    .[a1].CurrentRegion.Offset(1) = Empty
    .[a2].Resize(m, UBound(br, 2)) = br
    .Select
End With
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

循环筛选数据.rar (18.7 KB, 下载次数: 2)

2023-3-12 09:53 上传

点击文件名下载附件