一次提取符合要求的产品编码

blackttea1 · 发表于 2011-4-26 22:10

要求：对数据源中的B列编码提取不重复编码,其相对应编码C列中所有前四位编码为"0727"与"0754"的产品编码提取并成行显示,如数据源中用颜色表示的编码,要求用程序解决,谢谢!

[ 本帖最后由 blackttea1 于 2011-4-26 23:53 编辑 ]

zhaogang1960 · 发表于 2011-4-26 23:27

试试
Sub Macro1()
Dim d As Object, arr, brr(), crr(), lc$, i&, m&, s$
Set d = CreateObject("scripting.dictionary")
arr = Sheets("数据源").Range("A1").CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 255)
ReDim crr(UBound(arr))
For i = 2 To UBound(arr)
      If Left(arr(i, 3), 4) = "0727" Or Left(arr(i, 3), 4) = "0754" Then
         s = arr(i, 2)
         If Not d.Exists(s) Then
            m = m + 1
            d(s) = m
            brr(m, 1) = s
            brr(m, 2) = arr(i, 3)
         Else
            crr(d(s)) = crr(d(s)) + 1
            lc = IIf(crr(d(s)) > lc, crr(d(s)), lc)
            brr(d(s), crr(d(s)) + 2) = arr(i, 3)
         End If
      End If
Next
ActiveSheet.UsedRange.Offset(1).ClearContents
[b2].Resize(m, lc + 2) = brr
End Sub

[ 本帖最后由 zhaogang1960 于 2011-4-26 23:38 编辑 ]

zhaogang1960 · 发表于 2011-4-26 23:32

附件

Book1.rar (9.8 KB, 下载次数: 89)

[ 本帖最后由 zhaogang1960 于 2011-4-26 23:39 编辑 ]

blackttea1 · 发表于 2011-4-26 23:33

谢谢Zhaogang 1960老师，我不需要所有与这对应的编码，只要相对应编码C列中所有前四位编码为"0727"与"0754"的产品编码，谢谢！

zhaogang1960 · 发表于 2011-4-26 23:35

原帖由 blackttea1 于 2011-4-26 23:33 发表
谢谢Zhaogang 1960老师，我不需要所有与这对应的编码，只要相对应编码C列中所有前四位编码为"0727"与"0754"的产品编码，谢谢！

疏忽了，上面已经修改
If Left(arr(i, 3), 4) = "0727" Or Left(arr(i, 3), 4) = "0754" Then'更确切

[ 本帖最后由 zhaogang1960 于 2011-4-26 23:37 编辑 ]

blackttea1 · 发表于 2011-4-26 23:53

谢谢Zhaogang 1960老师，已完全达到我的要求，多次受教，深表感激，保重！

mouse711 · 发表于 2014-2-16 12:22

ppt2013中模块未找到

		自动登录	找回密码
密码			免费注册

[已解决] 一次提取符合要求的产品编码