[已解决]表格录入求助

531tommy

我需要根据Sheet2的条件在Sheet1中找出对应的零件品号，需要把分布在不同区域的规格显示出来；
自己编写的VB只会统计总数的提取，但如何通过二维数组把蓝色的位置如何匹配就不懂了，请各位大神们指教，谢谢
Sub text()
    Dim d, ar, br, str, i%, k&, s&
    Set d = CreateObject("scripting.dictionary")
    Set D1 = CreateObject("scripting.dictionary")
    Set D2 = CreateObject("scripting.dictionary")
    Qty = Sheet2.[D1]: gg = Sheet2.[b1]
    ar = Sheet1.Range("A1").CurrentRegion
    For i = LBound(ar) To UBound(ar)
        If ar(i, 5) <> "" Then
        d(ar(i, 2)) = d(ar(i, 2)) + ar(i, 5)                     '相同货品求和,不分仓库
        D1(ar(i, 2)) = D1(ar(i, 2)) + 1                          '统计所有仓库,同一货品的规格数
        End If
    Next

    For i = 2 To UBound(ar)
        If d(ar(i, 2)) > Qty And D1(ar(i, 2)) > gg Then         '判断总数>QTY,规格数大于GG的进行提取
            k = k + 1
           D2(k) = ar(i, 2) & "|" & d(ar(i, 2)) & "|" & D1(ar(i, 2)) & "|" & ar(i, 1) '行
        End If
    Next
End Sub


二维数组求助.zip (19.46 KB, 下载次数: 15)

2022-5-24 14:41 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

sam-wang

2022-5-24 21:02

請測試看看，謝謝
Sub test()
Dim Arr, Ar, xD, xD1, xD2, Brr(), T$, R&, R1&, C%, Ct%, Qty%, i&
Set xD = CreateObject("Scripting.Dictionary")   'count、xR
Set xD1 = CreateObject("Scripting.Dictionary")  'count+Qty
Set xD2 = CreateObject("Scripting.Dictionary")  'Row1
Ct = Sheets(2).[b1]: Qty = Sheets(2).[d1]
Arr = Sheet1.Range("A1").CurrentRegion
For i = 2 To UBound(Arr)
    T = Arr(i, 2): T1 = T & "|" & Arr(i, 4)
    If xD.Exists(T) Then
        If Not xD2.Exists(T1) Then
            xD2(T1) = xD2(T1) + 1
            xD(T) = xD(T) + xD2(T1)
        End If
    Else
        xD2(T1) = 1: xD(T) = 1
    End If
    xD(Arr(i, 2) & "_Qty") = xD(T & "_Qty") + Arr(i, 5) 'count+Qty
Next
xD2.RemoveAll
For i = 2 To UBound(Arr)
    T = Arr(i, 2): If xD(T) > Ct And xD(T & "_Qty") > Qty Then xD1(T) = ""
Next
For i = 2 To UBound(Arr)
    T = Arr(i, 2): If xD1.Exists(T) Then xD2(Arr(i, 4)) = 1 'xD2:Row1
Next
If xD2.Count < 1 Then MsgBox "Nothing": Exit Sub
With Sheets(2)
    .[a3].CurrentRegion.Offset(1, 0) = ""
    With .Range("e4").Resize(1, xD2.Count)
        .Value = xD2.keys
        .Sort Key1:=.Item(1), Order1:=1, _
        Header:=2, OrderCustom:=1, Orientation:=2
    End With
    .[a4] = "Name": .[b4] = "Total": .[c4] = "Spec": .[d4] = "WH"
    Ar = .Range("a4", .Cells(4, xD2.Count + 4))
End With
ReDim Brr(1 To 1000, 1 To xD2.Count + 4)
For i = 2 To UBound(Arr)
    T = Arr(i, 2): If Not xD1.Exists(T) Then GoTo 96
    C = Application.Match(Arr(i, 4), Ar, 0)
    If xD.Exists(T & "|" & Arr(i, 1)) Then
        R1 = xD(T & "|" & Arr(i, 1)): Brr(R1, C) = Arr(i, 5)
    Else
        R = R + 1: xD(T & "|" & Arr(i, 1)) = R
        Brr(R, 1) = Arr(i, 2): Brr(R, 2) = xD(T & "_Qty")
        Brr(R, 3) = xD(T): Brr(R, 4) = Arr(i, 1)
        Brr(R, C) = Arr(i, 5)
    End If
96: Next
With Sheets(2)
    With .[a5].Resize(R, xD2.Count + 4)
        .Value = Brr
        .Sort Key1:=.Item(1), Order1:=2, _
        Key2:=.Item(4), Order2:=1, Header:=2, Orientation:=1
    End With
End With
End Sub

跳转到最佳答案楼层

sam-wang

請測試看看，謝謝
Sub test()
Dim Arr, Ar, xD, xD1, xD2, Brr(), T$, R&, R1&, C%, Ct%, Qty%, i&
Set xD = CreateObject("Scripting.Dictionary")   'count、xR
Set xD1 = CreateObject("Scripting.Dictionary")  'count+Qty
Set xD2 = CreateObject("Scripting.Dictionary")  'Row1
Ct = Sheets(2).[b1]: Qty = Sheets(2).[d1]
Arr = Sheet1.Range("A1").CurrentRegion
For i = 2 To UBound(Arr)
    T = Arr(i, 2): T1 = T & "|" & Arr(i, 4)
    If xD.Exists(T) Then
        If Not xD2.Exists(T1) Then
            xD2(T1) = xD2(T1) + 1
            xD(T) = xD(T) + xD2(T1)
        End If
    Else
        xD2(T1) = 1: xD(T) = 1
    End If
    xD(Arr(i, 2) & "_Qty") = xD(T & "_Qty") + Arr(i, 5) 'count+Qty
Next
xD2.RemoveAll
For i = 2 To UBound(Arr)
    T = Arr(i, 2): If xD(T) > Ct And xD(T & "_Qty") > Qty Then xD1(T) = ""
Next
For i = 2 To UBound(Arr)
    T = Arr(i, 2): If xD1.Exists(T) Then xD2(Arr(i, 4)) = 1 'xD2:Row1
Next
If xD2.Count < 1 Then MsgBox "Nothing": Exit Sub
With Sheets(2)
    .[a3].CurrentRegion.Offset(1, 0) = ""
    With .Range("e4").Resize(1, xD2.Count)
        .Value = xD2.keys
        .Sort Key1:=.Item(1), Order1:=1, _
        Header:=2, OrderCustom:=1, Orientation:=2
    End With
    .[a4] = "Name": .[b4] = "Total": .[c4] = "Spec": .[d4] = "WH"
    Ar = .Range("a4", .Cells(4, xD2.Count + 4))
End With
ReDim Brr(1 To 1000, 1 To xD2.Count + 4)
For i = 2 To UBound(Arr)
    T = Arr(i, 2): If Not xD1.Exists(T) Then GoTo 96
    C = Application.Match(Arr(i, 4), Ar, 0)
    If xD.Exists(T & "|" & Arr(i, 1)) Then
        R1 = xD(T & "|" & Arr(i, 1)): Brr(R1, C) = Arr(i, 5)
    Else
        R = R + 1: xD(T & "|" & Arr(i, 1)) = R
        Brr(R, 1) = Arr(i, 2): Brr(R, 2) = xD(T & "_Qty")
        Brr(R, 3) = xD(T): Brr(R, 4) = Arr(i, 1)
        Brr(R, C) = Arr(i, 5)
    End If
96: Next
With Sheets(2)
    With .[a5].Resize(R, xD2.Count + 4)
        .Value = Brr
        .Sort Key1:=.Item(1), Order1:=2, _
        Key2:=.Item(4), Order2:=1, Header:=2, Orientation:=1
    End With
End With
End Sub

531tommy

sam-wang 发表于 2022-5-24 21:02
請測試看看，謝謝
Sub test()
Dim Arr, Ar, xD, xD1, xD2, Brr(), T$, R&, R1&, C%, Ct%, Qty%, i&

是的，十分感谢