请教推算符合金额的单元格数量

ysjhxh

请教个问题，1表是汇总表，2表是数据明细表。
如图黄色是A、B、C 3个公司的应收款余额，要推算G列的账期。
这个账期意思，由明细表，最下面的日期往上推，这个余额，要几个月的销售额才能覆盖掉。
举例：
“以B1为基准日”，基准日是1月31日，
比如A公司的应收余额是25万，由明细的【1月31日】往前推，最近日期是1月，那A公司1月、12月、11月，3个月的销售共30万，可以覆盖掉25万，这样就可以推断，A公司占用的销售额账期为：
252874.96/300000*3=2.5
同理，B公司要7个月，共70万，所以占用资金账期为：
619276.6/700000*7
C公司同理。
请教各位老师，用VBA如何做这段代码。 应收监控请教.rar (10.7 KB, 下载次数: 4)

2019-1-21 13:36 上传

点击文件名下载附件

ysjhxh

在这里，先提前感谢每位热心回复，和帮助的老师，感谢！

ysjhxh

在线等。请教……

lsdongjh

1. Sub Test()
   
2.     Dim shData As Worksheet, shResult As Worksheet
   
3.     Dim arr As Variant, brr As Variant
   
4.     Dim lngRow As Long, dateCur As Date
   
5.     Dim objDic As Object, objCount As Object
   
6.     Dim strKey As String, dblItem As Double
   
7.    
   
8.     Set shData = Sheets("销售明细")
   
9.     Set shResult = Sheets("账龄表")
   
10.    
    
11.     lngRow = shResult.Range("A" & Rows.Count).End(xlUp).Row
    
12.     arr = shResult.Range("A1:G" & lngRow)
    
13.     lngRow = shData.Range("A" & Rows.Count).End(xlUp).Row
    
14.     brr = shData.Range("A2:C" & lngRow)
    
15.    
    
16.     dateCur = arr(1, 2)
    
17.     Set objDic = CreateObject("Scripting.Dictionary")
    
18.     Set objCount = CreateObject("Scripting.Dictionary")
    
19.    
    
20.     For lngRow = LBound(arr) + 2 To UBound(arr)
    
21.         strKey = arr(lngRow, 1)
    
22.         dblItem = arr(lngRow, 2)
    
23.         objDic(strKey) = dblItem
    
24.     Next
    
25.    
    
26.     For lngRow = UBound(brr) To LBound(brr) Step -1
    
27.         If brr(lngRow, 1) < dateCur Then
    
28.             strKey = brr(lngRow, 2)
    
29.             dblItem = objDic(strKey)
    
30.             If dblItem > 0 Then
    
31.                 objCount(strKey) = objCount(strKey) + 1
    
32.                 dblItem = dblItem - brr(lngRow, 3)
    
33.                 objDic(strKey) = dblItem
    
34.             End If
    
35.         End If
    
36.     Next
    
37.    
    
38.     For lngRow = LBound(arr) + 2 To UBound(arr)
    
39.         strKey = arr(lngRow, 1)
    
40.         dblItem = arr(lngRow, 2) + Abs(objDic(strKey))
    
41.         arr(lngRow, 7) = Round(arr(lngRow, 2) / dblItem * objCount(strKey), 2)
    
42.     Next
    
43.    
    
44.     shResult.Range("A1").Resize(UBound(arr), 7) = arr
    
45. End Sub

复制代码

ysjhxh

lsdongjh 发表于 2019-1-21 15:01

非常非常感谢。看起来好难啊。不过执行起来很快。非常感谢。提前祝您新年快乐