一个统计表，急呼版主&大神999遍

csgsg2015

求助各位朋友
共有三个表 输入表  输出表  查询码表
实现以下功能：
1.输入表调用查询码表中相对应的查询码  
2.名称拆分为两部分（名称  规格型号）显示到输出表   拆分规则：以第一个空格为拆分点    其余相应不变
3.图号、名称相同的  数量进行叠加

输出表内已填写结果作为参考，详见附件  先行谢过各位朋友  好人一生平安。

砂海

那么在查询表中直接把 C D 拆成3列不就好了,
现在这样纯属玩花活. 不是实际应用的好方法.

金樽空对月

用函数做的，因为你的输入表里的内容格式和查询表内的内容格式有不一样的地方，所以输出表内的查询码查询不到，其他的都正常，如果你的数据量有变化，你只需把公式内的数据区域做相应改动即可。

金樽空对月

里面也用了两处辅助列，这样有助于数据转移。

grf1973

1. Sub tt()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Set d1 = CreateObject("scripting.dictionary")
   
4.     arr = Sheets("输入表").[a1].CurrentRegion
   
5.     brr = Sheets("查询码表").[a1].CurrentRegion
   
6.     ReDim crr(1 To UBound(arr), 1 To 7)
   
7.     For i = 2 To UBound(brr)
   
8.         d1(brr(i, 1)) = brr(i, 2)
   
9.     Next
   
10.     For i = 2 To UBound(arr)
    
11.         x = arr(i, 2) & arr(i, 3)
    
12.         If Len(x) Then
    
13.             If Not d.exists(x) Then
    
14.                 n = n + 1
    
15.                 d(x) = n
    
16.                 y = arr(i, 3)
    
17.                 crr(n, 7) = d1(y)      '查询码
    
18.                 crr(n, 1) = arr(i, 2)   '图号
    
19.                 crr(n, 6) = arr(i, 5)    '材料
    
20.                 yrr = Split(y, " ")
    
21.                 crr(n, 2) = yrr(0)      '名称
    
22.                 crr(n, 3) = Replace(y, yrr(0), "")  '规格型号
    
23.             End If
    
24.             crr(d(x), 5) = crr(d(x), 5) + arr(i, 4) '数量
    
25.         End If
    
26.     Next
    
27.     With Sheets("输出表")
    
28.         .[a2:g10000].ClearContents
    
29.         .[a2].Resize(n, 7) = crr
    
30.     End With
    
31. End Sub

复制代码

grf1973

请看附件。

csgsg2015

grf1973 发表于 2015-10-13 09:55
请看附件。

十分感谢大侠   
还有点小问题   当输入表没有数据的时候  点击按钮会报错

grf1973

加个判断。

1. Sub tt()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Set d1 = CreateObject("scripting.dictionary")
   
4.     arr = Sheets("输入表").[a1].CurrentRegion
   
5.     brr = Sheets("查询码表").[a1].CurrentRegion
   
6.     If UBound(arr) < 2 Then MsgBox "输入入表无内容": Exit Sub
   
7.     ReDim crr(1 To UBound(arr), 1 To 7)
   
8.     For i = 2 To UBound(brr)
   
9.         d1(brr(i, 1)) = brr(i, 2)
   
10.     Next
    
11.     For i = 2 To UBound(arr)
    
12.         x = arr(i, 2) & arr(i, 3)
    
13.         If Len(x) Then
    
14.             If Not d.exists(x) Then
    
15.                 n = n + 1
    
16.                 d(x) = n
    
17.                 y = arr(i, 3)
    
18.                 crr(n, 7) = d1(y)      '查询码
    
19.                 crr(n, 1) = arr(i, 2)   '图号
    
20.                 crr(n, 6) = arr(i, 5)    '材料
    
21.                 yrr = Split(y, " ")
    
22.                 crr(n, 2) = yrr(0)      '名称
    
23.                 crr(n, 3) = Replace(y, yrr(0), "")  '规格型号
    
24.             End If
    
25.             crr(d(x), 5) = crr(d(x), 5) + arr(i, 4) '数量
    
26.         End If
    
27.     Next
    
28.     With Sheets("输出表")
    
29.         .[a2:g10000].ClearContents
    
30.         .[a2].Resize(n, 7) = crr
    
31.     End With
    
32. End Sub
    

复制代码

csgsg2015

grf1973 发表于 2015-10-13 13:57
加个判断。

大赞 非常感谢