[已解决]VBA求助：材料申购计划

绝峰 · 发表于 2011-10-23 14:43

本帖最后由绝峰于 2011-10-23 16:55 编辑

VBA求助：材料申购计划

材料申购计划.rar (22.53 KB, 下载次数: 17)

2011-10-23 16:55 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

mxg825

2011-10-25 22:59

本帖最后由 mxg825 于 2011-10-26 16:40 编辑

回复绝峰的帖子

有了这个按日期生成申请查询单,
第一个程序本人认为没有意义了!

昨晚花了2个小时才把代码写好！
2011-10-26 17：00代码更正好请重新下载！

Sub 当天申购单()
Dim D As New Dictionary '建立字典 (主键 key 值（产品名称&类别），Item值（D数组的行号字符串）
Dim ID As New Dictionary '建立字典(主键 key 值（材料代码），Item值（CARR 列号）
Dim Aarr, Barr, Carr(), Darr
'Aarr ：申购表详细数据 (下简称A数组）
'Barr ：字典D 的 Item值字符串转换成数组 (下简称B数组）
'Carr()：申购单打印生成数据的数组，随需要可增加列数（也就是不够就增加）(下简称C数组）
'Darr ：明细表详细数据（产品用料用量表）(下简称D数组）
Dim X&, Y&, K& '循环体的变量
Dim MYdate As Date '把[B2]的值交给一个日期变量
Dim CCOL&, DCOL& 'C数组的行号，D 数组的行号
If Not IsDate([B2]) Then MsgBox "[B2]输入非日期格式", , "中止": Exit Sub
Application.ScreenUpdating = False '关闭刷新提高速度
Sheets("申购单打印").Range("a4:F" & Sheets("申购单打印").Range("a65536").End(xlUp).Row + 1).Clear '清空旧数据
On Error Resume Next '忽略出错
Aarr = Sheets("申购表").Range("a4:D" & Sheets("申购表").Range("a65536").End(xlUp).Row) 'A数组赋值
Darr = Sheets("明细表").Range("a3:G" & Sheets("明细表").Range("a65536").End(xlUp).Row) 'D数组赋值
MYdate = [B2] '日期变量赋值
For X = 1 To UBound(Darr) '循环D数组建立D字典，
D(Darr(X, 1) & Darr(X, 2)) = D(Darr(X, 1) & Darr(X, 2)) & X & ","
'主键 key 值（产品名称&类别）=Item值（该主健对应的D数组行号串联，也就是每个产品用料的行号字符串【，】分隔符号）
Next
For X = 1 To UBound(Aarr) '循环A数组
If Aarr(X, 1) = MYdate Then '对比日期
Barr = Split(D(Aarr(X, 2) & Aarr(X, 3)), ",") '字典D 的 Item值字符串转换成数组（每个产品对应的材料的行号）
For Y = 0 To UBound(Barr) - 1 '循环B数组
DCOL = Barr(Y) '每个产品对应的材料的行号交给变量
If ID.Exists(Darr(DCOL, 3)) Then '查看 ID 字典是否存在这个【材料代码】
CCOL = ID(Darr(DCOL, 3)) '存在：取这个材料在 C 数组中的列号！
Carr(5, CCOL) = Carr(5, CCOL) + Darr(DCOL, 7) * Aarr(X, 4) '材料数量累加
Carr(6, CCOL) = Carr(6, CCOL) & "／" & Aarr(X, 2) & Left(Aarr(X, 3), 1) & "=" & _
Darr(DCOL, 7) * Aarr(X, 4) & Darr(DCOL, 6) '备注信息（串联了下方备注信息）
Else '不存在
K = K + 1 '加一列
ID(Darr(DCOL, 3)) = K '字典ID 新添一个！'主键 key 值（材料代码）=Item值（C数组所在列号）
ReDim Preserve Carr(1 To 6, 1 To K) 'Carr数组增加一列
Carr(1, K) = Darr(DCOL, 3) '材料代码
Carr(2, K) = Darr(DCOL, 4) '材料名称
Carr(3, K) = Darr(DCOL, 5) '规格
Carr(4, K) = Darr(DCOL, 6) '单位
Carr(5, K) = Darr(DCOL, 7) * Aarr(X, 4) '材料用量* 产品套数
Carr(6, K) = Aarr(X, 2) & Left(Aarr(X, 3), 1) & "=" & Darr(DCOL, 7) * Aarr(X, 4) & Darr(DCOL, 6)
'备注信息= 产品名称 &产品规格（"单人位"，截取为“单”) & "=" & 材料用量* 产品套数 & 单位
End If
Next Y
End If
Next X
With Sheets("申购单打印").Range("A4").Resize(K, 6)
.Value = Application.Transpose(Carr) 'C数组导到工作表
.Sort key1:=Columns("A") '排序
.Borders.LineStyle = 1 '加网格线
End With
Application.ScreenUpdating = True '开启刷新
MsgBox "需要申购材料共有" & K & "种", , "MXG825提示"
End Sub

复制代码

注释写这么清楚应该能看懂了吧？

跳转到最佳答案楼层

绝峰 · 发表于 2011-10-23 16:57

回复绝峰的帖子

材料申购计划.rar (22.53 KB, 下载次数: 18)

绝峰 · 发表于 2011-10-23 17:12

绝峰发表于 2011-10-23 16:57
回复绝峰的帖子

VBA求助：材料申购计划
附件已修改

材料申购计划.rar (22.53 KB, 下载次数: 13)

mxg825 · 发表于 2011-10-23 17:47

本帖最后由 mxg825 于 2011-10-23 17:47 编辑

回复绝峰的帖子

只完成第一部分！

绝峰 · 发表于 2011-10-23 18:07

为什么下载文件会失败：显示临时文件或所在磁盘不可写！

mxg825 · 发表于 2011-10-23 20:14

2、已申购数要求汇总所有小于最后下单日期的合计数

已申购数数据来源是在哪里？

mxg825 · 发表于 2011-10-23 20:22

本帖最后由 mxg825 于 2011-10-23 23:28 编辑

还有，你的材料有几百种。。。。
按列排的话，03版只有256列，是不够的！
建议用07版

下面的附件是2007版以上才能打开！有一万多列！

绝峰 · 发表于 2011-10-24 10:47

为什么下载文件会失败：显示临时文件或所在磁盘不可写！
有什么办法让它恢复正常？急！！！

mxg825 · 发表于 2011-10-24 11:35

绝峰发表于 2011-10-24 10:47
为什么下载文件会失败：显示临时文件或所在磁盘不可写！
有什么办法让它恢复正常？急！！！

是不是你下载的盘符不可写？（或是满了）
你试一下右键另存为！自己找个硬盘路径（或换台电脑试试）

绝峰 · 发表于 2011-10-24 11:50

运行错误
.Columns("E:XFD").Delete

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

[已解决]VBA求助：材料申购计划

RE: VBA求助：材料申购计划