（已解决）请问如何计算仓储费（特别感谢Ib_bn、jxb8088、fanjy）！

自守之贼

大家好！先祝大家节日愉快！祝论坛越办越好！

  我现在的问题是：我公司有仓储业务这一块，客户的煤堆放在我司仓库，我们向客户收取仓储费，每吨每天收取0.25元，如6-1日进货439.34吨，那么6-1日的仓储费就是439.34吨*0.25元*1天=109.84元，6-3日出货200吨，那么6-3日当天的仓储费是（439.34-200）*0.25*1=59.84元，客户的煤出入库频繁，每个月计算仓储费和打对帐单（对帐单需要当日明细）都够我头痛了，也不知道我表达清楚没有？我已上传附件，烦请论坛的朋友帮忙看下呵！

[ 本帖最后由 自守之贼 于 2009-9-30 09:22 编辑 ]

jxb8088

Private Sub CommandButton1_Click()
y = Year([a4])
m = Month([a4])
For i = 1 To DateDiff("d", DateSerial(y, m, 1), DateSerial(y, m + 1, 1))
Sheets(2).Cells(i + 1, 1) = DateSerial(y, m, i)
Set rng = [a:a].Find(what:=DateSerial(y, m, i), lookat:=xlWhole)
If i <> 1 Then
If rng Is Nothing Then
Sheets(2).Cells(i + 1, 2) = Sheets(2).Cells(i, 2)
Sheets(2).Cells(i + 1, 3) = Round(Sheets(2).Cells(i + 1, 2) * 0.25, 2)
Else
Sheets(2).Cells(i + 1, 2) = Sheets(2).Cells(i, 2) + rng.Offset(0, 2) - rng.Offset(0, 3)
Sheets(2).Cells(i + 1, 3) = Round(Sheets(2).Cells(i + 1, 2) * 0.25, 2)
End If
Else
If rng Is Nothing Then
Sheets(2).Cells(i + 1, 2) = 0
Sheets(2).Cells(i + 1, 3) = 0
Else
Sheets(2).Cells(i + 1, 2) = rng.Offset(0, 2) - rng.Offset(0, 3)
Sheets(2).Cells(i + 1, 3) = Round(Sheets(2).Cells(i + 1, 2) * 0.25, 2)
End If
End If
Next
End Sub

自守之贼

原帖由 jxb8088 于 2009-9-29 11:30 发表
Private Sub CommandButton1_Click()
y = Year([a4])
m = Month([a4])
For i = 1 To DateDiff("d", DateSerial(y, m, 1), DateSerial(y, m + 1, 1))
Sheets(2).Cells(i + 1, 1) = DateSerial(y, m, i)
Set rng  ...

非常感激你的关注以及热心帮助！没想到这么快就有了令人满意的结果，谢谢你百忙之中抽出时间来帮助我这个菜鸟解决问题，但我现在又有一个新的问题出来了，如果我新增了客户又该怎么样去实现呢？原来的永红是0.25元/天，新增的客户今店是0.2元/天，我们现在已经有二十多个客户，而且每个客户的仓储费在0.25元/天的基础上会略有浮动，不知道这种情况也可以实现吗？详情请见附件，烦请再出手相助呵！

fanjy

2. Sub Calculate()
   
3.     Dim lDays As Long, i As Long, j As Long
   
4.     Dim rngFindRange As Range, rngFind As Range, rngFound As Range
   
5.     Dim lLastRow As Long, varVal
   
6.    
   
7.     '填充仓储费工作表
   
8.     lDays = wksInfo.Range("A65536").End(xlUp) - wksInfo.Range("A4")
   
9.     wksCal.Range("A2") = wksInfo.Range("A4")
   
10.     For i = 1 To lDays
    
11.         wksCal.Range("A2").Offset(i, 0) = wksCal.Range("A2") + i
    
12.     Next i
    
13.     wksCal.Range("B2:B" & lDays + 2).ClearContents
    
14.    
    
15.     Set rngFindRange = wksCal.Range("A2:A" & lDays + 2)
    
16.     Set rngFind = wksInfo.Range("A4")
    
17.    
    
18.     Do
    
19.         Set rngFound = rngFindRange.Find(rngFind)
    
20.         rngFound.Offset(0, 1) = rngFound.Offset(0, 1) + rngFind.Offset(0, 2) - rngFind.Offset(0, 3)
    
21.         For i = rngFound.Row + 1 To lDays + 2
    
22.             wksCal.Range("B" & i) = rngFound.Offset(0, 1)
    
23.         Next i
    
24.         Set rngFind = rngFind.Offset(1, 0)
    
25.     Loop While rngFind <> ""
    
26.    
    
27.     wksCal.Range("C2:C" & lDays + 2).FormulaR1C1 = "=RC[-1]*0.25"
    
28. End Sub

Sub Calculate()<br />     Dim lDays As Long, i As Long, j As Long<br />     Dim rngFindRange As Range, rngFind As Range, rngFound As Range<br />     Dim lLastRow As Long, varVal<br />     <br />     '填充仓储费工作表<br />     lDays = wksInfo.Range("A65536").End(xlUp) - wksInfo.Range("A4")<br />     wksCal.Range("A2") = wksInfo.Range("A4")<br />     For i = 1 To lDays<br />         wksCal.Range("A2").Offset(i, 0) = wksCal.Range("A2") + i<br />     Next i<br />     wksCal.Range("B2:B" & lDays + 2).ClearContents<br />     <br />     Set rngFindRange = wksCal.Range("A2:A" & lDays + 2)<br />     Set rngFind = wksInfo.Range("A4")<br />     <br />     Do<br />         Set rngFound = rngFindRange.Find(rngFind)<br />         rngFound.Offset(0, 1) = rngFound.Offset(0, 1) + rngFind.Offset(0, 2) - rngFind.Offset(0, 3)<br />         For i = rngFound.Row + 1 To lDays + 2<br />             wksCal.Range("B" & i) = rngFound.Offset(0, 1)<br />         Next i<br />         Set rngFind = rngFind.Offset(1, 0)<br />     Loop While rngFind <> ""<br />     <br />     wksCal.Range("C2:C" & lDays + 2).FormulaR1C1 = "=RC[-1]*0.25"<br /> End Sub

自守之贼

原帖由 fanjy 于 2009-9-29 13:02 发表
Sub Calculate()
    Dim lDays As Long, i As Long, j As Long
    Dim rngFindRange As Range, rngFind As Range, rngFound As Range
    Dim lLastRow As Long, varVal
   
    '填充仓储费工作表
    lDa ...

得到大家的热心帮助，我感激不尽！版主，你的答案同样也是我想要的结果，你们大家都帮了我的大忙，我现在的问题是如果新增了客户，而且仓储费用不一样，又该怎么样去实现呢？原谅我的得寸进尺啊。已经在3楼重新上传了附件。烦请再出手相助，呵呵。

lb_bn

没有数值为0的那一行输出。
结果输出在H后的四列，楼主可自行修改。

自守之贼

原帖由 lb_bn 于 2009-9-29 14:13 发表
没有数值为0的那一行输出。
结果输出在H后的四列，楼主可自行修改。

谢谢你的热心帮助呵，但是这个宏在本月就可以用，如果到了下月，不能计算下月的仓储费用了，烦请再帮忙看下。已上传附件！

自守之贼

致4楼版主：
   版主，你好！大家要实现我7楼的想法，估计需要点时间，大家抽出这么多的时间来帮助我，我深感幸运，但我不想大家再为我这个问题花更多的时间在上面了，因为论坛还有别的人需要帮助，但最后有个请求，现抛开7楼的想法，可以把你在4楼的代码帮我完善下吗？我已经上传了附件。谢谢了呵！

lb_bn

pr = Range("G3:G5").Value
把这里原来的G4改成G5就行了啊.
静下心来就很快可以看出来了.[em07]

lb_bn

如果不想每次都改就用下面这句
pr = range("G3:G" & range("G65536").end(3).row).value

改了一个完善的,用于年度的.   如果到了2010后要改一下年份.

Private Sub CommandButton1_Click()
    Dim i0, i, ii, i3, x, y, arr1(), arr2()
    Dim dic1 As Object
    Set dic1 = CreateObject("scripting.dictionary")
    x = Range("A65536").End(3).Row
    arr1 = Range("A4:D" & x).Value
    dic1(0) = 0
    For i = 1 To x - 3
        dic1(arr1(i, 2)) = dic1(arr1(i, 2)) + 1
    Next
    On Error Resume Next
    ld = DateValue(DateSerial(2009, Month(arr1(x - 3, 1)) + 1, 0))
    v = dic1.items
    pr = Range("G3:G" & Range("G65536").End(3).Row).Value
    Sheets("仓储费").Range("H2:K65536").ClearContents
    For i0 = 1 To dic1.Count
        z = z + v(i0 - 1)
        Erase arr1
        arr1 = Range("A" & 4 + z).Resize(v(i0), 4).Value
        ReDim arr2(1 To ld - arr1(1, 1) + 1, 1 To 4)
        y = 0
        For i = 1 To v(i0)
            If i = v(i0) Then
                For ii = 1 To ld - arr1(i, 1) + 1
                y = y + 1
                arr2(y, 1) = arr1(1, 1) + y - 1
                arr2(y, 2) = arr1(1, 2)
                For i3 = 1 To i
                    arr2(y, 3) = arr2(y, 3) + arr1(i3, 3) - arr1(i3, 4)
                Next
                arr2(y, 4) = arr2(y, 3) * pr(i0, 1)
            Next
            Else
            For ii = 1 To arr1(i + 1, 1) - arr1(i, 1)
                y = y + 1
                arr2(y, 1) = arr1(1, 1) + y - 1
                arr2(y, 2) = arr1(1, 2)
                For i3 = 1 To i
                    arr2(y, 3) = arr2(y, 3) + arr1(i3, 3) - arr1(i3, 4)
                Next
                arr2(y, 4) = arr2(y, 3) * pr(i0, 1)
            Next
            End If
        Next
        With Sheets("仓储费")
            tr = .[H1].CurrentRegion.Rows.Count + 1
            .Range("H" & tr).Resize(UBound(arr2), 4).Value = arr2
            Erase arr2
        End With
    Next
    If Err.Number <> 0 Then Err.Clear
    On Error GoTo 0
    Erase arr1, arr2, pr, v
    Set dic1 = Nothing
End Sub

[ 本帖最后由 lb_bn 于 2009-9-29 19:58 编辑 ]