求先进先出法仓库账的代码

840205910

不知道我注释得对不对？望各位老师纠正指教！

AVEL

1. Option Explicit
   
2. Private Sub Worksheet_Change(ByVal Target As Range)
   
3.     If Target.Column = 9 And Target.Count = 1 Then
   
4.         Dim arr As Variant
   
5.         Dim d As Object
   
6.         Dim nt As Long
   
7.         Dim smin As Long, smax As Long
   
8.         Dim i As Integer, j As Integer
   
9.         Dim hs As Variant
   
10.         Dim ssum As Long, tsum As Long
    
11.         Dim minr As Integer, maxr As Integer
    
12.         Application.EnableEvents = False
    
13.         arr = Range("f5:n" & [a65536].End(3).Row)
    
14.         nt = Application.Sum(Range([i5], Target.Offset(-1)))
    
15.         If nt + Target.Value > Application.Sum([f:f]) Then GoTo ll
    
16.         If Target.Value = "" Then GoTo ll
    
17.         Set d = CreateObject("Scripting.Dictionary")
    
18.         For i = 1 To UBound(arr)
    
19.             If Len(arr(i, 1)) Then d(i) = arr(i, 2)
    
20.         Next
    
21.         hs = d.keys
    
22.         For j = 0 To UBound(hs)
    
23.             If nt >= smin Then smin = smin + arr(hs(j), 1): minr = j
    
24.             If nt + Target.Value >= smax Then smax = smax + arr(hs(j), 1): maxr = j
    
25.         Next
    
26.         If smin - nt >= Target.Value Then
    
27.             Target.Offset(, 1).Value = arr(hs(minr), 2)
    
28.             Target.Offset(, 2).Value = Target.Offset(, 1).Value * Target.Value
    
29.         Else
    
30.             ssum = ssum + (smin - nt) * arr(hs(minr), 2)
    
31.             tsum = Target.Value - (smin - nt)
    
32.             For i = minr + 1 To maxr
    
33.                 If tsum > arr(hs(i), 1) Then
    
34.                     ssum = ssum + arr(hs(i), 1) * arr(hs(i), 2)
    
35.                     tsum = tsum - arr(hs(i), 1)
    
36.                 Else
    
37.                     ssum = ssum + tsum * arr(hs(i), 2)
    
38.                 End If
    
39.             Next
    
40.             Target.Offset(, 1).Value = ssum / Target.Value
    
41.             Target.Offset(, 2).Value = ssum
    
42.             End If
    
43.             Target.Offset(, 3).Resize(, 3).FormulaR1C1 = Array("=SUM(R5C6:RC[-6])-SUM(R5C9:RC[-3])", "=RC[1]/RC[-1]", "=SUM(R5C8:RC[-6])-SUM(R5C11:RC[-3])")
    
44.     End If
    
45.     Application.EnableEvents = True
    
46.     Set d = Nothing
    
47.     Exit Sub
    
48. ll:
    
49.     Target.Value = "": Target.Resize(, 6).Value = ""
    
50.      Application.EnableEvents = True
    
51. End Sub

复制代码

AVEL

试试先
EH(AVEL)-账页 12-07-15 18-57.rar (12.18 KB, 下载次数: 205)

2012-7-15 18:57 上传

点击文件名下载附件

白云2011

不知道那里还有点问题。后面那行不对。
开始我想是否需要建立保留99批次数组.可能做错了。
Sub s()
Dim i&, j, ar
ar = Range("A1:R" & [I65536].End(3).Row + 1)
ar(4, 12) = 0: ar(4, 13) = 0: ar(4, 14) = 0
ar(5, 15) = ar(5, 6): ar(5, 16) = ar(5, 7)
For i = 5 To UBound(ar) - 1
ar(i, 15) = Abs(ar(i - 1, 12) - ar(i, 9))  '先进部分（库存
ar(i, 16) = ar(i - 1, 13)  '0
If ar(i, 15) = 0 Then j = 0 Else j = 2
ar(i, 15 + j) = ar(i, 6)  '后进部分（入库
ar(i, 16 + j) = ar(i, 7)
If ar(i, 6) <> "" Then ar(i, 8) = ar(i, 7) * ar(i, 6) '[购进]金额
   ar(i, 12) = ar(i - 1, 12) + ar(i, 6) - ar(i, 9) '[库存]剩余数量
   If ar(i, 9) = "" Then '没出库 [库存] 金额 = 遗留+入库。
   ar(i, 14) = ar(i - 1, 14) + ar(i, 8) '[库存]  金额
   ar(i, 13) = Round(ar(i, 14) / ar(i, 12), 2) '[库存]单价
Else '出库 先处理 [领用]单价
   If ar(i - 1, 15) >= ar(i, 9) Then '如果先进货量充足
      ar(i, 10) = ar(i - 1, 13) '[领用]单价
      ar(i, 11) = ar(i, 9) * ar(i, 10) '[领用]金额
      ar(i, 14) = ar(i - 1, 14) + ar(i, 8) - ar(i, 11) '[库存]金额
      ar(i, 13) = Round(ar(i, 14) / ar(i, 12), 2) '[库存]单价
   Else ''''''''用到先进和先出
      j = (ar(i, 9) - ar(i - 1, 15)) * ar(i - 1, 18)
      ar(i, 11) = Round(ar(i - 1, 15) * ar(i - 1, 16) + j, 2) '[领用]单价
   End If
   ar(i, 10) = Round(ar(i, 11) / ar(i, 9), 2) '[领用]金额
   ar(i, 14) = ar(i - 1, 14) + ar(i, 8) - ar(i, 11) '[库存]金额
   ar(i, 13) = Round(ar(i, 14) / ar(i, 12), 2) '[库存]单价
End If
Next
ar(4, 12) = "数量": ar(4, 13) = "单价": ar(4, 14) = "金额"
[A1].Resize(UBound(ar), 18) = ar
End Sub

840205910

AVEL 发表于 2012-7-15 18:56

谢谢AVEL老师，我仔细阅读研究一下。不过还是想请你帮我注释一下10楼的代码关键部分，谢谢！

840205910

白云2011 发表于 2012-7-16 00:12
不知道那里还有点问题。后面那行不对。
开始我想是否需要建立保留99批次数组.可能做错了。
Sub s()

你的附件不一样？能上传你的附件吗？

sctsg

试试，A 列不为空就可自动计算

840205910

AVEL 发表于 2012-7-15 18:56

老师，是不是这样理解？

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lie, ha
lie = Target.Column
ha = Target.Row
If lie = 7 Or lie = 6 Then
Cells(ha, 8) = Cells(ha, 6) * Cells(ha, 7)
End If

If lie = 8 Then
If Cells(ha, 6) = 0 Then
Cells(ha, 7) = 0
Else
Cells(ha, 7) = Cells(ha, 8) / Cells(ha, 6)
End If
End If





    If Target.Column = 9 And Target.Count = 1 Then
        Dim arr As Variant
        Dim d As Object
        Dim nt As Long
        Dim smin As Long, smax As Long
        Dim i As Integer, j As Integer
        Dim hs As Variant
        Dim ssum As Long, tsum As Long
        Dim minr As Integer, maxr As Integer
        Application.EnableEvents = False
        arr = Range("f5:n" & [a65536].End(3).Row) '把九列数据装入数组
        nt = Application.Sum(Range([i5], Target.Offset(-1))) '本次领用前的所有领用之和
        If nt + Target.Value > Application.Sum([f:f]) Then GoTo ll '若领用之和大于购进之和则从目标列处起后6列为空
        If Target.Value = "" Then GoTo ll '若目标值为空则从目标列处起后6列为空
        Set d = CreateObject("Scripting.Dictionary") '字典
        For i = 1 To UBound(arr) '循环
            If Len(arr(i, 1)) Then d(i) = arr(i, 2) '写入字典
        Next
        hs = d.keys '关键词
        For j = 0 To UBound(hs)
            If nt >= smin Then smin = smin + arr(hs(j), 1): minr = j '本次领用前的所有领用之和大于等于前批购进之和？******
            If nt + Target.Value >= smax Then smax = smax + arr(hs(j), 1): maxr = j '所有领用之和大于等于总购进之和？************
        Next
        If smin - nt >= Target.Value Then '前批剩余大于本次领用
            Target.Offset(, 1).Value = arr(hs(minr), 2) '领用价格=前批价格
            Target.Offset(, 2).Value = Target.Offset(, 1).Value * Target.Value '领用金额=前批价格*本次领用数量
        Else '否则
            ssum = ssum + (smin - nt) * arr(hs(minr), 2) '领用金额为前批剩余金额之和
            tsum = Target.Value - (smin - nt) '本次领用数量为前批剩余数量
            For i = minr + 1 To maxr '
                If tsum > arr(hs(i), 1) Then '本次领用数量大于前批剩余数量
                    ssum = ssum + arr(hs(i), 1) * arr(hs(i), 2) '领用金额为前批剩余金额+不足数量*新价格
                    tsum = tsum - arr(hs(i), 1) '
                Else '否则
                    ssum = ssum + tsum * arr(hs(i), 2) '领用金额为领用数量*新价格
                End If
            Next
            Target.Offset(, 1).Value = ssum / Target.Value '10列的数据（领用价格）
            Target.Offset(, 2).Value = ssum '11列的数据（领用金额）
            End If
            Target.Offset(, 3).Resize(, 3).FormulaR1C1 = Array("=SUM(R5C6:RC[-6])-SUM(R5C9:RC[-3])", "=RC[1]/RC[-1]", "=SUM(R5C8:RC[-6])-SUM(R5C11:RC[-3])") '给12、13、14列写公式
    End If
    Application.EnableEvents = True
    Set d = Nothing
    Exit Sub
ll:
    Target.Value = "": Target.Resize(, 6).Value = "" '若目标值为空则从目标列处起后6列为空
     Application.EnableEvents = True
End Sub

840205910

sctsg 发表于 2012-7-16 09:14
试试，A 列不为空就可自动计算

这是什么文件，打开方式用什么？请明示！

AVEL

840205910 发表于 2012-7-16 10:14
老师，是不是这样理解？

Private Sub Worksheet_Change(ByVal Target As Range)

理解基本上正确了啊。
呵呵 不过我也不知道会不会中间哪里没考虑好，你最好找个已经做好的正确文件做一下测试。