|
发表于 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
复制代码 注释写这么清楚 应该能看懂了吧?
|
评分
-
查看全部评分
|