20170814xlVBA限定日期按客户分类汇总

Posted 2020-10-02

原始数据表：

汇总格式：

 

 

Sub subtotalDic()
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim oSht As Worksheet
    Dim mYear As String
    Dim mMon As String
    Dim Arr As Variant
    Dim i As Long, j As Long
    
    Dim Dic As Object
    Set Dic = CreateObject("Scripting.Dictionary")
    Set Wb = Application.ThisWorkbook
    Set Sht = Wb.Worksheets("销售台账")
    Set oSht = Wb.Worksheets("每月汇总")
    
    With oSht
        mYear = .Range("A2").Text
        mMon = .Range("C2").Text
    End With
    
    With Sht
        endrow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        If endrow <= 3 Then Exit Sub
        Set Rng = .Range("A4:N" & endrow)
        Arr = Rng.Value
        For i = LBound(Arr) To UBound(Arr)
            If CStr(Arr(i, 1)) = mYear And CStr(Arr(i, 2)) = mMon Then
                Key = CStr(Arr(i, 4))
                Dic(Key) = Dic(Key) + Arr(i, 8)
            End If
        Next i
    End With
    
    With oSht
        endrow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
        For i = 5 To endrow
            Key = .Cells(i, 2).Text
            .Cells(i, 3).Value = Dic(Key)
        Next i
        
        endrow = .Cells(.Cells.Rows.Count, 5).End(xlUp).Row
        For i = 5 To endrow
            Key = .Cells(i, 5).Text
            .Cells(i, 6).Value = Dic(Key)
        Next i
    End With
    
    
    Set Wb = Nothing
    Set Sht = Nothing
    Set oSht = Nothing
    Set Rng = Nothing
    Set Dic = Nothing
    
End Sub