每月的仓储费用报表的自动生成

dsco

问题：我公司有仓储业务这一块，客户的煤堆放在我司仓库，我们向客户收取仓储费，每吨每天收取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元，客户的煤出入库频繁，每个月计算仓储费和打对帐单（对帐单需要当日明细）都够我头痛了，也不知道我表达清楚没有？我已上传附件，烦请论坛的朋友帮忙看下呵！
    又：现在又有一个新的问题出来了，如果我新增了客户又该怎么样去实现呢？原来的永红是0.25元/天，新增的客户今店是0.2元/天，我们现在已经有二十多个客户，而且每个客户的仓储费在0.25元/天r4的基础上会略有浮动，不知道这种情况也可以实现吗？详情请见附件，烦请再出手相助呵！

解答：
首先在MainPro过程中判断“出入库表”中有几个客户，然后将每个客户的数据存储在单元格区域对象变量中，将该变量作为参数传递到计算仓储量的 CalculateFill过程中，该过程计算每个客户在规定时间每天的仓储量，然后使用CalculateResultr4过程计算仓储费。
具体程序代码如下：

Sub MainPro()

    '完全清除仓储费工作表中已有的数据
    Dim lLastRow1 As Long
    lLastRow1 = wksCal.Range("A65536").End(xlUp).Row
    If lLastRow1 >= 2 Then wksCal.Range("A2:D" & lLastRow1).ClearContents

    '找到出入库表中不同数据开始的行号
    Dim lRows() As Long, lLastRow2 As Long, i As Long
    Dim rng As Range
    i = 1
    ReDim Preserve lRows(1 To i)
    lRows(i) = 4
    Set rng = wksInfo.Range("B4")
    Do Until rng.Offset(1, 0) = ""
        If rng <> rng.Offset(1, 0) Then
            i = i + 1
            ReDim Preserve lRows(1 To i)
            lRows(i) = rng.Offset(1, 0).Row
        End If
        Set rng = rng.Offset(1, 0)
    Loop

    Set rng = Nothing

    lLastRow2 = wksInfo.Range("A65536").End(xlUp).Row
    '没有r4数据则退出
    If lLastRow2 = 3 Then Exit Sub

    '传递区域进行填充
    Dim rngPass As Range
    If UBound(lRows) > 1 Then
        For i = 1 To UBound(lRows) - 1
            Set rngPass = wksInfo.Range("A" & lRows(i) & ":" & "A" & lRows(i + 1) - 1)
            Call CalculateFill(rngPass)
        Next i
        '防止最后一个不同的数据项只有1行数据
        Set rngPass = wksInfo.Range("A" & lRows(UBound(lRows)) & ":" & "A" & lLastRow2)
        Call CalculateFill(rngPass)
    Else
        '没有不同的数据项
        Set rngPass = wksInfo.Range("A4:A" & lLastRow2)
        Call CalculateFill(rngPass)
    End If

    Set rngPass = Nothing
End Sub


Sub CalculateFill(rng)
    Dim lDays As Long, i As Long
    Dim lLastRow As Long, lLastRow1 As Long
    Dim MaxDay

    Application.ScreenUpdating = False

    lLastRow = wksCal.Range("A65536").End(xlUp).Row
    lLastRow1 = wksInfo.Range("A65536").End(xlUp).Row

    MaxDay = Application.WorksheetFunction.Max(wksInfo.Range("A4:A" & lLastRow1))

'    lDays = rng.Cells(rng.Rows.Count, 1) - rng.Cells(1, 1)
    lDays = MaxDay - rng.Cells(1, 1)

    wksCal.Range("A" & lLastRow + 1) = rng.Cells(1, 1)

    '填充日期
    For i = 1 To lDays
        wksCal.Range("A" & lLastRow + 1).Offset(i, 0) = rng.Cells(1, 1) + i
    Next i


    '计算存放吨数
    Dim rngFind As Range, rngFindRange As Range, rngFound As Range
    Dim varValue, j As Long

    '查找的区域
    Set rngFindRange = wksCal.Range("A" & lLastRow + 1 & ":" & "A" & lLastRow + lDays + 1)

    '查找存放的日期并计算值
    For Each rngFind In rng
        Set rngFound = rngFindRange.Find(rngFind)
        rngFound.Offset(0, 1) = rngFind.Offset(0, 1)
        rngFound.Offset(0, 2) = rngFound.Offset(0, 2) + rngFind.Offset(0, 2) - rngFind.Offset(0, 3)
        varValue = rngFound.Offset(0, 2).Value
        j = 0
        For i = rngFound.Row To lLastRow + lDays
            j = j + 1
            wksCal.Range("A" & rngFound.Row + j).Offset(0, 1) = rngFound.Offset(0, 1)
            wksCal.Range("A" & rngFound.Row + j).Offset(0, 2) = varValue
        Next i
    Next rngFind

    Application.ScreenUpdating = True
    '计算费用
    Call CalculateResult
End Sub

Sub CalculateResult()
    Dim lLastRow As Long
    lLastRow = wksCal.Range("A65536").End(xlUp).Row
    Application.ScreenUpdating = False
    wksCal.Range("D2:D" & lLastRow).FormulaR1C1 = "=VLookup(RC[-2],ProList,2,False)*RC[-1]"
    '转换公式为值
    wksCal.Range("D2:D" & lLastRow).Value = wksCal.Range("D2:D" & lLastRow).Value
    Application.ScreenUpdating = True
End Sub

AVEL

没看到你所说的附件啊？？？
请确认一下。