|
- Sub Test2()
- Dim arrSource As Variant, lngKey As Long, dblItem As Double, dblSum As Double
- Dim lngRows As Long, lngCols As Long
- Dim objDicAll As Object, arrKeys As Variant
- Dim objDicMonth As Object, lngMonth As Long
- Dim lngRow As Long, lngCol As Long
- Dim arrResult As Variant, lngIndex As Long
-
- arrSource = Sheet1.UsedRange
- lngRows = UBound(arrSource)
- lngCols = UBound(arrSource, 2)
-
- Set objDicAll = CreateObject("Scripting.Dictionary")
- Set objDicMonth = CreateObject("Scripting.Dictionary")
-
- For lngCol = 1 To lngCols Step 2
- For lngRow = 2 To lngRows
- If arrSource(lngRow, lngCol) <> "" And arrSource(lngRow, lngCol + 1) <> "" Then
- lngKey = Format(CStr(arrSource(lngRow, lngCol)), "yyyymmdd")
- dblItem = arrSource(lngRow, lngCol + 1)
- objDicAll(lngKey) = objDicAll(lngKey) + dblItem
- lngKey = Mid(lngKey, 1, 6)
- objDicMonth(lngKey) = objDicMonth(lngKey) + dblItem
- dblSum = dblSum + dblItem
- End If
- Next
- Next
-
- lngRows = objDicAll.Count + objDicMonth.Count + 1
- ReDim arrResult(1 To lngRows, 1 To 2)
-
- arrKeys = objDicAll.keys
- lngIndex = 1
-
- For lngRow = 1 To UBound(arrKeys) + 1
- lngKey = Application.WorksheetFunction.Small(arrKeys, lngRow)
- dblItem = objDicAll(lngKey)
-
- If lngMonth = 0 Then
- lngMonth = Mid(lngKey, 1, 6)
- Else
- If Mid(lngKey, 1, 6) <> lngMonth Then
- arrResult(lngIndex, 1) = "小计"
- arrResult(lngIndex, 2) = objDicMonth(lngMonth)
- lngIndex = lngIndex + 1
- lngMonth = Mid(lngKey, 1, 6)
- End If
- End If
-
- arrResult(lngIndex, 1) = Format(lngKey, "0/00/00")
- arrResult(lngIndex, 2) = dblItem
- lngIndex = lngIndex + 1
- Next
-
- arrResult(lngIndex, 1) = "小计"
- arrResult(lngIndex, 2) = objDicMonth(lngMonth)
- lngIndex = lngIndex + 1
-
- arrResult(lngIndex, 1) = "合计"
- arrResult(lngIndex, 2) = dblSum
-
- Sheet2.Range("A2:B" & Rows.Count).ClearContents
- Sheet2.Range("A2").Resize(lngIndex, 2) = arrResult
-
- MsgBox "OK"
- End Sub
复制代码 |
|