|
- Sub Test()
- Dim shData As Worksheet, shResult As Worksheet
- Dim arr As Variant, brr As Variant
- Dim lngRow As Long, dateCur As Date
- Dim objDic As Object, objCount As Object
- Dim strKey As String, dblItem As Double
-
- Set shData = Sheets("销售明细")
- Set shResult = Sheets("账龄表")
-
- lngRow = shResult.Range("A" & Rows.Count).End(xlUp).Row
- arr = shResult.Range("A1:G" & lngRow)
- lngRow = shData.Range("A" & Rows.Count).End(xlUp).Row
- brr = shData.Range("A2:C" & lngRow)
-
- dateCur = arr(1, 2)
- Set objDic = CreateObject("Scripting.Dictionary")
- Set objCount = CreateObject("Scripting.Dictionary")
-
- For lngRow = LBound(arr) + 2 To UBound(arr)
- strKey = arr(lngRow, 1)
- dblItem = arr(lngRow, 2)
- objDic(strKey) = dblItem
- Next
-
- For lngRow = UBound(brr) To LBound(brr) Step -1
- If brr(lngRow, 1) < dateCur Then
- strKey = brr(lngRow, 2)
- dblItem = objDic(strKey)
- If dblItem > 0 Then
- objCount(strKey) = objCount(strKey) + 1
- dblItem = dblItem - brr(lngRow, 3)
- objDic(strKey) = dblItem
- End If
- End If
- Next
-
- For lngRow = LBound(arr) + 2 To UBound(arr)
- strKey = arr(lngRow, 1)
- dblItem = arr(lngRow, 2) + Abs(objDic(strKey))
- arr(lngRow, 7) = Round(arr(lngRow, 2) / dblItem * objCount(strKey), 2)
- Next
-
- shResult.Range("A1").Resize(UBound(arr), 7) = arr
- End Sub
复制代码 |
评分
-
1
查看全部评分
-
|