[已解决]汇总求助

yjqsamol

求助：

      自动汇总代码编写求助，详见附件。
       汇总求助.rar (7.49 KB, 下载次数: 65)

2011-11-3 13:36 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

liuguansky

2011-11-3 16:24

1. Sub justtest()
   
2.     Dim D As New Dictionary, Arr, i&, j As Byte, ArrR(), K&
   
3.     '定义变量，字典对象前期绑定，需引用VBE工具下MS SCRIPTING.RUNTIME
   
4.     Arr = Sheet2.Range("A1").CurrentRegion.Value
   
5.     '获取代码与进货名称关系表数据
   
6.     On Error GoTo 100 '设置错误跳转
   
7.     For i = 2 To UBound(Arr) '循环
   
8.         D.Add Arr(i, 1), Arr(i, 2) '添加代号入字典项目，如果重复则生成错误
   
9.     Next i
   
10.     With Sheet1 '代号库存日明细写入数组，方便后续调用处理
    
11.         Arr = .Range("A5:ah" & .Cells(.Rows.Count, 1).End(3).Row).Value
    
12.     End With
    
13.     For i = 1 To UBound(Arr) Step 3 '循环库存项目
    
14.         If D.Exists(Arr(i, 1)) Then '如果代号在关系表中存在，则
    
15.             If Not D.Exists(D(Arr(i, 1))) Then '如果进货名称在结果中不存在，则
    
16.                 K = K + 1: D.Add D(Arr(i, 1)), K '添加进货名称入字典项目KEY，同时对行号进行累加标识
    
17.                 ReDim Preserve ArrR(1 To 33, 1 To K) '动态定义结果存放数组
    
18.                 ArrR(1, K) = D(Arr(i, 1)): ArrR(2, K) = Arr(i, 3) '赋数组第一二项值
    
19.             End If
    
20.             For j = 4 To UBound(Arr, 2) '循环日记录
    
21.                 If Len(Arr(i, j)) Then '如果非空
    
22.                     ArrR(j - 1, D(D(Arr(i, 1)))) = ArrR(j - 1, D(D(Arr(i, 1)))) + Arr(i, j)
    
23.                     '则累加对应的结果数组位置元素的数量
    
24.                 End If
    
25.             Next j
    
26.         End If
    
27.     Next i
    
28.     With Sheet3
    
29.         .Range("a4:ag" & .Rows.Count).Clear '清空结果区域
    
30.         With .Range("a4").Resize(K, 33)
    
31.             .Value = Application.Transpose(ArrR) '返回结果
    
32.             .Borders.LineStyle = xlContinuous '设置边框
    
33.         End With
    
34.     End With
    
35.     Exit Sub
    
36. 100     MsgBox "代号不惟一，请确认后重新运行程序。": End
    
37. '对代号不惟一进行提示，并结束程序。
    
38. End Sub
    

复制代码

请看附件效果：
汇总求助.rar (15.82 KB, 下载次数: 28)

2011-11-3 16:24 上传

点击文件名下载附件

跳转到最佳答案楼层

爱疯

1. 
   
2. Private Sub CommandButton1_Click()
   
3.     Dim A(), B(), C(), i%, j%, k%, l%
   
4. 
   
5.     With Sheets("sheet1")
   
6.         A = .Range("a5:ah" & .Range("c5").End(xlDown).Row).Value
   
7.     End With
   
8.     With Sheets("sheet2")
   
9.         B = .Range("a1:B" & .Range("A1").End(xlDown).Row).Value
   
10.     End With
    
11.     With Sheets("库存明细")
    
12.         C = .Range("a3:ag" & .Range("a3").End(xlDown).Row).Value
    
13.     End With
    
14. 
    
15.     For i = 2 To UBound(C)
    
16.         For j = 3 To UBound(C, 2)
    
17.             C(i, j) = 0    '防止连续运行时，把sheet3表中的结果累计进来
    
18.             For k = 2 To UBound(B)
    
19.                 If B(k, 2) = C(i, 1) Then
    
20.                     For l = 1 To UBound(A)
    
21.                         If A(l, 1) = B(k, 1) Then
    
22.                             C(i, j) = C(i, j) + A(l, j + 1)
    
23.                         End If
    
24.                     Next l
    
25.                 End If
    
26.             Next k
    
27.         Next j
    
28.     Next i
    
29.     Sheets("库存明细").Range("a3").Resize(UBound(C), UBound(C, 2)) = C
    
30. End Sub

复制代码

汇总求助2.rar (13.53 KB, 下载次数: 17)

2011-11-3 15:34 上传

点击文件名下载附件

liuts

路过学习的

yjqsamol

回复 liuts 的帖子

非常感谢！
假设
     1.我没有设定库存明细  
      2. sheet1和sheet2的行数要增加
然后要达到库存明细表的结果和格式

请问该如何实现呀？

liuguansky

1. Sub justtest()
   
2.     Dim D As New Dictionary, Arr, i&, j As Byte, ArrR(), K&
   
3.     '定义变量，字典对象前期绑定，需引用VBE工具下MS SCRIPTING.RUNTIME
   
4.     Arr = Sheet2.Range("A1").CurrentRegion.Value
   
5.     '获取代码与进货名称关系表数据
   
6.     On Error GoTo 100 '设置错误跳转
   
7.     For i = 2 To UBound(Arr) '循环
   
8.         D.Add Arr(i, 1), Arr(i, 2) '添加代号入字典项目，如果重复则生成错误
   
9.     Next i
   
10.     With Sheet1 '代号库存日明细写入数组，方便后续调用处理
    
11.         Arr = .Range("A5:ah" & .Cells(.Rows.Count, 1).End(3).Row).Value
    
12.     End With
    
13.     For i = 1 To UBound(Arr) Step 3 '循环库存项目
    
14.         If D.Exists(Arr(i, 1)) Then '如果代号在关系表中存在，则
    
15.             If Not D.Exists(D(Arr(i, 1))) Then '如果进货名称在结果中不存在，则
    
16.                 K = K + 1: D.Add D(Arr(i, 1)), K '添加进货名称入字典项目KEY，同时对行号进行累加标识
    
17.                 ReDim Preserve ArrR(1 To 33, 1 To K) '动态定义结果存放数组
    
18.                 ArrR(1, K) = D(Arr(i, 1)): ArrR(2, K) = Arr(i, 3) '赋数组第一二项值
    
19.             End If
    
20.             For j = 4 To UBound(Arr, 2) '循环日记录
    
21.                 If Len(Arr(i, j)) Then '如果非空
    
22.                     ArrR(j - 1, D(D(Arr(i, 1)))) = ArrR(j - 1, D(D(Arr(i, 1)))) + Arr(i, j)
    
23.                     '则累加对应的结果数组位置元素的数量
    
24.                 End If
    
25.             Next j
    
26.         End If
    
27.     Next i
    
28.     With Sheet3
    
29.         .Range("a4:ag" & .Rows.Count).Clear '清空结果区域
    
30.         With .Range("a4").Resize(K, 33)
    
31.             .Value = Application.Transpose(ArrR) '返回结果
    
32.             .Borders.LineStyle = xlContinuous '设置边框
    
33.         End With
    
34.     End With
    
35.     Exit Sub
    
36. 100     MsgBox "代号不惟一，请确认后重新运行程序。": End
    
37. '对代号不惟一进行提示，并结束程序。
    
38. End Sub
    

复制代码

请看附件效果：
汇总求助.rar (15.82 KB, 下载次数: 28)

2011-11-3 16:24 上传

点击文件名下载附件

yjqsamol

回复 liuguansky 的帖子

谢谢liuguansky

再麻烦你帮忙解决一下这个帖子，和本帖类似的
  http://www.excelpx.com/thread-205614-1-2.html

yuhe0008

其实这个结果，用数据透视表也能完成了

yjqsamol

回复 yjqsamol 的帖子

类似，但稍微复杂些呢；
因为自身不具备VB能力，所以求助

yjqsamol

回复 yuhe0008 的帖子

数据透视表可以跨表进行吗？求教~

yjqsamol

回复 爱疯 的帖子

我的这个文件的编码错在哪里，请教？
汇总求助.rar (23.03 KB, 下载次数: 12)

2011-11-3 19:35 上传

点击文件名下载附件