楼主
liuguansky |
Q：
平常我会购买一些材料、工具等等物品，这些物品我可能是买了之后直接放到了仓库，那么当我是新购买的时候，sheet1表P列中就为空，证明是新购买的，而如果是从一个地方调拨到另一个地方去的话，那么就是调拨，那么在P列我就要写上是从哪个地方拿出来的，在Q列上，我就会写上拿到哪个地方去！那么如果是新购买的话，这样物品的总量肯定就会增加了，而如果是调拨的话，无论这个物品调到哪里去，总量肯定还是那么多，不会变动。如何来区别什么样的条件为1种物品呢？那就是G、H、I、J4列合并起来的值是唯一的时候，以此来判定这是一种物品。我现在就要知道，每一种物品在每一个地方有多少个，价格是按入库（购买时）的总金额除以入库（购买时）的总量来算平均值的A：用如下代码可以实现：
- Sub justtest()
- Dim Arr, D, i&, StrTemp1$, StrTemp2$, ArrR(), K&, m&
- On Error GoTo 100
- Set D = CreateObject("scripting.dictionary") '创建字典项目
- With Sheet1
- Arr = .Range("g6:t" & .Cells(.Rows.Count, "g").End(3).Row).Value '获取待处理数据写入数组
- End With
- For i = 1 To UBound(Arr, 1) '循环
- StrTemp1 = Arr(i, 1) & Arr(i, 2) & Arr(i, 3) & Arr(i, 4) & Arr(i, 11) '设定惟一值，加以产品区别
- StrTemp2 = Arr(i, 1) & Arr(i, 2) & Arr(i, 3) & Arr(i, 4) & Arr(i, 10)
- If D.exists(StrTemp1) Then '判断是否存在
- ArrR(7, D(StrTemp1)) = ArrR(7, D(StrTemp1)) + Arr(i, 7) '存在即累加数量
- If Len(Arr(i, 10)) Then '若是调转的
- m = Arr(i, 7) * ArrR(9, D(StrTemp2)) / ArrR(7, D(StrTemp2)) '确认平均单价后的金额
- ArrR(7, D(StrTemp2)) = ArrR(7, D(StrTemp2)) - Arr(i, 7) '调整转出地区数量
- ArrR(9, D(StrTemp1)) = ArrR(9, D(StrTemp1)) + m '调整转入地区金额
- ArrR(9, D(StrTemp2)) = ArrR(9, D(StrTemp2)) - m '调整转出地区金额
- Else: ArrR(9, D(StrTemp1)) = ArrR(9, D(StrTemp1)) + Arr(i, 9) '若非调转，直接累加金额
- End If
- Else: K = K + 1: ReDim Preserve ArrR(1 To 12, 1 To K) '不存在项目，则扩展动态数组
- D.Add StrTemp1, K: ArrR(1, K) = K '添加字典项目，初始化数组各元素
- ArrR(2, K) = Arr(i, 1): ArrR(3, K) = Arr(i, 2)
- ArrR(4, K) = Arr(i, 3): ArrR(5, K) = Arr(i, 4)
- ArrR(6, K) = Arr(i, 6): ArrR(7, K) = Arr(i, 7)
- ArrR(10, K) = Arr(i, 11): ArrR(11, K) = Arr(i, 13): ArrR(12, K) = Arr(i, 14)
- If Len(Arr(i, 10)) Then '判断是否为调转
- ArrR(9, K) = ArrR(7, K) * ArrR(9, D(StrTemp2)) / ArrR(7, D(StrTemp2)) '同前处理
- ArrR(7, D(StrTemp2)) = ArrR(7, D(StrTemp2)) - Arr(i, 7)
- ArrR(9, D(StrTemp2)) = ArrR(9, D(StrTemp2)) - ArrR(9, K)
- Else: ArrR(9, K) = Arr(i, 9)
- End If
- End If
- Next i
- For i = 1 To K
- ArrR(8, i) = Format(ArrR(9, i) / ArrR(7, i), "0.00") '产生单价
- Next i
- With Sheet2
- .Range("a6:l" & .Rows.Count).ClearContents
- .Range("a6").Resize(K, 12) = Application.Transpose(ArrR)
- End With
- MsgBox "处理完毕.", vbOKOnly
- Set D = Nothing
- Exit Sub
- 100
- MsgBox "存在未入库，直接调整拨记录，请查示！", vbOKOnly '错误提示
- End Sub
 该贴已经同步到 |