Excel精英培训网

 找回密码
 注册

QQ登录

只需一步,快速开始

数据透视表40+个常用小技巧,让你一次学会!
查看: 158|回复: 2

[已解决]表格录入求助

[复制链接]
发表于 2022-5-24 14:41 | 显示全部楼层 |阅读模式
我需要根据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)
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 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

1.JPG
回复

使用道具 举报

 楼主| 发表于 2022-5-24 21:28 | 显示全部楼层
sam-wang 发表于 2022-5-24 21:02
請測試看看,謝謝
Sub test()
Dim Arr, Ar, xD, xD1, xD2, Brr(), T$, R&, R1&, C%, Ct%, Qty%, i&

是的,十分感谢
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2022-8-15 12:09 , Processed in 0.157741 second(s), 9 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表