仓储费用根据仓储时间计算各批次仓储费，求VBA代码

chenwenming

仓储费用计算根据各批货物入库时间长短及费率计算，求VBA代码，谢谢！

一指禅62

https://club.excelhome.net/threa ... tml?_dsign=1c3686ff

jaxxcyh

1. Sub 仓储费用()
   
2. Dim arr()   '原始信息
   
3. Dim brr()
   
4. r = [a1].End(xlDown).Row
   
5. arr = Range("a1").Resize(r, 6).Value
   
6. 
   
7. Dim mydic As Object
   
8. Set mydic = CreateObject("scripting.dictionary")
   
9. For i = 1 To r - 1
   
10.     mydic(arr(i + 1, 2)) = 0
    
11. Next
    
12. 
    
13. i = 0
    
14. For Each Key In mydic.keys
    
15.     i = i + 1
    
16.     mydic(Key) = i
    
17. Next
    
18. 
    
19. ReDim brr(1 To r + mydic.Count, 1 To 10)
    
20. Dim inputDate As String
    
21. Dim jiesuanDate As Date
    
22. 
    
23. 
    
24. 
    
25. inputDateStr:
    
26. inputDate = InputBox("结算时间是:", "请输入结算时间")
    
27. If ChkDateFormat(inputDate) Then
    
28.     jiesuanDate = CDate(inputDate)
    
29. Else
    
30.     MsgBox "输入的日期格式有误，请按照yyyy-mm-dd格式（如2024-2-17）重新输入"
    
31.     GoTo inputDateStr
    
32. End If
    
33. 
    
34. 
    
35. n = 0
    
36. For i = 1 To r - 1                         '逐行扫描原始数据
    
37.     If arr(i + 1, 4) > 0 Then              '搜索进库记录
    
38.         n = n + 1
    
39.         brr(n, 1) = arr(i + 1, 2)          '获取批次
    
40.         brr(n, 2) = "入"                    '出入库
    
41.         brr(n, 3) = arr(i + 1, 1)           '时间
    
42.         brr(n, 4) = jiesuanDate              '结算时间
    
43.         brr(n, 5) = arr(i + 1, 4)          '数量
    
44.         kucun = brr(n, 5)
    
45.         brr(n, 6) = 0                      '天数
    
46.         brr(n, 7) = 0
    
47.         brr(n, 8) = 0
    
48.         brr(n, 9) = 0
    
49.         brr(n, 10) = 0
    
50.         For j = 1 To r - 1                 '从头搜索同批次出库记录
    
51.             If arr(j + 1, 5) > 0 And arr(j + 1, 2) = arr(i + 1, 2) Then
    
52.                 n = n + 1
    
53.                 brr(n, 1) = arr(j + 1, 2)          '获取批次
    
54.                 brr(n, 2) = "出"                   '出入库
    
55.                 brr(n, 3) = arr(j + 1, 1)          '变动时间
    
56.                 brr(n, 4) = jiesuanDate            '结算时间
    
57.                 brr(n, 5) = arr(j + 1, 5)          '变动数量
    
58.                 kucun = kucun - brr(n, 5)          '库存数量
    
59.                 brr(n, 6) = arr(j + 1, 1) - arr(i + 1, 1) '天数
    
60.                 If brr(n, 6) <= 5 Then
    
61.                     brr(n, 7) = brr(n, 6)
    
62.                     brr(n, 8) = 0
    
63.                     brr(n, 9) = 0
    
64.                 ElseIf brr(n, 6) <= 10 Then
    
65.                     brr(n, 7) = 5
    
66.                     brr(n, 8) = brr(n, 6) - 5
    
67.                     brr(n, 9) = 0
    
68.                 Else
    
69.                     brr(n, 7) = 5
    
70.                     brr(n, 8) = 5
    
71.                     brr(n, 9) = brr(n, 6) - 10
    
72.                 End If
    
73.                 brr(n, 10) = brr(n, 5) * brr(n, 8) * 1 + brr(n, 5) * brr(n, 9) * 0.5
    
74.                 Total = Total + brr(n, 10)
    
75.             End If
    
76.         Next
    
77.         
    
78.         '计算库存
    
79.         n = n + 1
    
80.         brr(n, 1) = arr(i + 1, 2)          '获取批次
    
81.         brr(n, 2) = "库"                    '出入库
    
82.         brr(n, 3) = jiesuanDate             '时间
    
83.         brr(n, 4) = jiesuanDate             '结算时间
    
84.         brr(n, 5) = kucun                   '数量
    
85.         brr(n, 6) = jiesuanDate - arr(i + 1, 1) '天数
    
86.         If brr(n, 6) <= 5 Then
    
87.             brr(n, 7) = brr(n, 6)
    
88.             brr(n, 8) = 0
    
89.             brr(n, 9) = 0
    
90.         ElseIf brr(n, 6) <= 10 Then
    
91.             brr(n, 7) = 5
    
92.             brr(n, 8) = brr(n, 6) - 5
    
93.             brr(n, 9) = 0
    
94.         Else
    
95.             brr(n, 7) = 5
    
96.             brr(n, 8) = 5
    
97.             brr(n, 9) = brr(n, 6) - 10
    
98.         End If
    
99.         brr(n, 10) = brr(n, 5) * brr(n, 8) * 1 + brr(n, 5) * brr(n, 9) * 0.5
    
100.         Total = Total + brr(n, 10)
     
101.         
     
102.         n = n + 1
     
103.         brr(n, 1) = "小计"
     
104.         brr(n, 10) = Total
     
105.         
     
106.         Total = 0
     
107.         kucun = 0
     
108.     End If
     
109. Next
     
110.                
     
111. Range("G26").Resize(UBound(brr, 1), UBound(brr, 2)).Value = brr
     
112. 
     
113.         
     
114. End Sub
     
115. 
     
116. 
     
117. Function ChkDateFormat(strDate As String) As Boolean
     
118.     On Error GoTo errhandler
     
119.     Dim dateValue As Date
     
120.     dateValue = CDate(strDate)
     
121.     ChkDateFormat = True
     
122.     Exit Function
     
123.    
     
124. errhandler:
     
125.     ChkDateFormat = False
     
126.    
     
127. End Function
     
128. 
     

复制代码

汉唐

练习下。

Sub test()
Dim i As Long, j As Long, n As Long, r As Long, m As Long
Dim arr, brr(1 To 1000, 1 To 20), s
Set d = CreateObject("scripting.dictionary")
'date1 = #1/31/2024#
date1 = CDate(Application.InputBox("请输入截止日期", "输入日期", Format(Date, "yyyy-mm-dd"), Type:=1))
If date1 = 0 Then Exit Sub
a = Array("批次", "出入库", "时间", "计算时点", "数量", "天数", "免收天数", "收1元天数", "收0.5元天数", "仓储费")
With Sheet1
r = .Cells(65536, 1).End(xlUp).Row
arr = .Cells(1, 1).Resize(r, 6)
End With
For i = 2 To UBound(arr)
s = arr(i, 2)
If arr(i, 1) <= date1 Then
If Abs(arr(i, 4)) + Abs(arr(i, 5)) > 0 Then
If Not d.exists(s) Then
d(s) = Array(arr(i, 1), i)
Else
d(s) = Array(d(s)(0), d(s)(1) & "|" & i)
End If
End If
End If
Next 'i
For Each s In a
m = m + 1
brr(1, m) = s
Next
n = 1
For Each s In d.keys
a = Split(d(s)(1), "|")
kk = 0
For Each s1 In a
n = n + 1
brr(n, 1) = s
brr(n, 2) = IIf(arr(Val(s1), 4) > 0, Left(arr(1, 4), 2), Left(arr(1, 5), 2))
brr(n, 3) = arr(Val(s1), 1)
brr(n, 4) = date1
brr(n, 5) = arr(Val(s1), 4) + arr(Val(s1), 5)
brr(n, 6) = arr(Val(s1), 1) - d(s)(0)
kk = kk + arr(Val(s1), 4) - arr(Val(s1), 5)
Next 'a
n = n + 1
brr(n, 1) = s
brr(n, 5) = kk
brr(n, 2) = "库存"
brr(n, 4) = date1
brr(n, 6) = Val(date1 - d(s)(0))
n = n + 1
brr(n, 1) = "小计"
Next 'i
kk = 0
For i = 2 To n
If brr(i, 6) <= 5 Then
brr(i, 7) = brr(i, 6)
brr(i, 10) = 0
ElseIf brr(i, 6) <= 10 Then
brr(i, 7) = 5
brr(i, 8) = (brr(i, 6) - 5)
brr(i, 9) = brr(i, 6) - 5
brr(i, 10) = brr(i, 5) * brr(i, 9) * 1
Else
brr(i, 7) = 5
brr(i, 8) = (10 - 5)
brr(i, 9) = (brr(i, 6) - 10)
brr(i, 10) = brr(i, 5) * (5 * 1 + brr(i, 9) * 0.5)
End If
kk = kk + brr(i, 10)
If brr(i, 1) = "小计" Then
brr(i, 10) = kk
kk = 0
End If
Next 'i
Sheet1.Cells(27, 7).Resize(1000, 10).ClearContents
Sheet1.Cells(27, 7).Resize(n, 10) = brr
End Sub

chenwenming

jaxxcyh 发表于 2024-8-6 01:31

谢谢，结果完全正确，如果数据表只是出入库流水，不人为添加库存行，计算时会出现错误，要是能按月分别结算仓储费就更好了，比如2月各发了400，单独计算2月的仓储费或分月形成仓储费计算表！

chenwenming

汉唐 发表于 2024-8-6 07:48
练习下。

Sub test()

谢谢，代码可以规避库存行的问题，结果正确！要是能按月分别结算仓储费就更好了，比如2月各发了400，单独计算2月的仓储费或分月形成仓储费计算表！

一招秒杀

1句10行，忘记加个小计了

chenwenming

一招秒杀 发表于 2024-8-6 15:07
1句10行，忘记加个小计了

可以将文件上传观摩下，谢谢

汉唐

试着写了下代码，不过结果好像跟楼主的举例结果有些不同，可能是我理解有误，姑且写之姑且看之，仅供参考

一招秒杀

加多了1行，偷个懒，每次只计算1个月的。