20170617xlVBA销售数据分类汇总

Public Sub SubtotalData()
    AppSettings
    'On Error GoTo ErrHandler
    Dim StartTime, UsedTime As Variant
    StartTime = VBA.Timer
    'Input code here

    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim oSht As Worksheet
    Dim Rng As Range
    Dim Arr As Variant

    Const HEAD_ROW As Long = 5
    Const SHEET_NAME As String = "分类汇总"
    Const START_COLUMN As String = "A"
    Const END_COLUMN As String = "Z"

    Const OTHER_HEAD_ROW As Long = 1
    'Const OTHER_SHEET_NAME As String = "DATA"
    Dim DataName As String
    Const OTHER_START_COLUMN As String = "A"
    Const OTHER_END_COLUMN As String = "Z"

    Dim Client As String    '客户名称
    Dim BookNo As String    '订单号
    Dim Status As String  '状态
    Dim Item As String    '统计项目
    Dim dClient As Object
    Dim dBookInfo As Object
    Dim MixKey As String
    Dim Key As String
    Dim TmpKey As String
    Dim OneClient
    Dim Index As Long

    Set dBookNo = CreateObject("Scripting.Dictionary")
    Set dBookInfo = CreateObject("Scripting.Dictionary")
    Set dClient = CreateObject("Scripting.Dictionary")

    Set Wb = Application.ThisWorkbook
    Set Sht = Wb.Worksheets(SHEET_NAME)
    With Sht
        .UsedRange.Offset(HEAD_ROW).ClearContents
        DataName = .Range("L2").Value
    End With

    If DataName = "" Then
        MsgBox "请输入查询范围!", vbInformation, "QQ "
        GoTo ErrorExit
    End If

    If DataName <> "全年" Then
        '判断某个月的！
        On Error Resume Next
        Set oSht = Wb.Worksheets(DataName)
        If oSht Is Nothing Then
            MsgBox "输入的月份(工作表名)有误，请重新输入!", vbInformation, "QQ "
            GoTo ErrorExit
        End If

        With oSht

            EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
            Set Rng = .Range(.Cells(OTHER_HEAD_ROW + 1, "A"), .Cells(EndRow, "Y"))
            'Debug.Print Rng.Address
            Arr = Rng.Value

            For i = LBound(Arr) To UBound(Arr)
                Client = CStr(Arr(i, 2))    '客户名称

                BookNo = CStr(Arr(i, 1))
                Status = CStr(Arr(i, 6))    '进度状态

                dClient(Client) = ""    '保存所有客户名称

                MixKey = Client & ";" & BookNo & ";" & Status
                Key = Client & ";" & Status    '客户，状态

                If dBookNo.Exists(MixKey) = False Then    '防止重复
                    TmpKey = Key & ";" & "定单量"
                    ' dBookCount(TmpKey) = dBookCount(TmpKey) + 1
                    dBookInfo(TmpKey) = dBookInfo(TmpKey) + 1
                    dBookNo(MixKey) = ""    '记下订单号，防止重复
                End If

                TmpKey = Key & ";" & "订单金额"
                dBookInfo(TmpKey) = dBookInfo(TmpKey) + Arr(i, 12)

                TmpKey = Key & ";" & "已收款金额"
                dBookInfo(TmpKey) = dBookInfo(TmpKey) + Arr(i, 13)

                TmpKey = Key & ";" & "出库金额"
                dBookInfo(TmpKey) = dBookInfo(TmpKey) + Arr(i, 14)

                TmpKey = Key & ";" & "未收款金额"
                dBookInfo(TmpKey) = dBookInfo(TmpKey) + Arr(i, 15)

            Next i
        End With

    Else

        For Each oSht In Wb.Worksheets
            If oSht.Name Like "*月" Then
                With oSht

                    EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
                    Set Rng = .Range(.Cells(OTHER_HEAD_ROW + 1, "A"), .Cells(EndRow, "Y"))
                    'Debug.Print Rng.Address
                    Arr = Rng.Value

                    For i = LBound(Arr) To UBound(Arr)
                        Client = CStr(Arr(i, 2))    '客户名称

                        BookNo = CStr(Arr(i, 1))
                        Status = CStr(Arr(i, 6))    '进度状态

                        dClient(Client) = ""    '保存所有客户名称

                        MixKey = Client & ";" & BookNo & ";" & Status
                        Key = Client & ";" & Status    '客户，状态

                        If dBookNo.Exists(MixKey) = False Then    '防止重复
                            TmpKey = Key & ";" & "定单量"
                            ' dBookCount(TmpKey) = dBookCount(TmpKey) + 1
                            dBookInfo(TmpKey) = dBookInfo(TmpKey) + 1
                            dBookNo(MixKey) = ""    '记下订单号，防止重复
                        End If

                        TmpKey = Key & ";" & "订单金额"
                        dBookInfo(TmpKey) = dBookInfo(TmpKey) + Arr(i, 12)

                        TmpKey = Key & ";" & "已收款金额"
                        dBookInfo(TmpKey) = dBookInfo(TmpKey) + Arr(i, 13)

                        TmpKey = Key & ";" & "出库金额"
                        dBookInfo(TmpKey) = dBookInfo(TmpKey) + Arr(i, 14)

                        TmpKey = Key & ";" & "未收款金额"
                        dBookInfo(TmpKey) = dBookInfo(TmpKey) + Arr(i, 15)

                    Next i
                End With

            End If
        Next oSht
    End If

    With Sht
        Index = 0
        For Each OneClient In dClient.keys
            Index = Index + 1
            .Cells(HEAD_ROW + Index, 1).Value = Index
            .Cells(HEAD_ROW + Index, 2).Value = OneClient

            For j = 3 To 12
                Status = .Cells(HEAD_ROW - 1, j).MergeArea.Cells(1, 1).Value
                Item = .Cells(HEAD_ROW, j).Value
                TmpKey = OneClient & ";" & Status & ";" & Item
                ' Debug.Print TmpKey
                .Cells(HEAD_ROW + Index, j).Value = dBookInfo(TmpKey)
                'Debug.Print Status
            Next j
        Next OneClient

        SetEdges Application.Intersect(.UsedRange.Offset(HEAD_ROW), .UsedRange)
    End With

    UsedTime = VBA.Timer - StartTime
    Debug.Print "UsedTime：" & Format(UsedTime, "0.000 Seconds")
    'MsgBox "UsedTime：" & Format(UsedTime, "0.000 Seconds"), vbOKOnly, "NextSeven  QQ "
ErrorExit:
    AppSettings False
    Exit Sub
ErrHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Description & "！", vbCritical, "NextSeven "
        Debug.Print Err.Description
        Err.Clear
        Resume ErrorExit
    End If
End Sub

Public Sub AppSettings(Optional IsStart As Boolean = True)
    If IsStart Then
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        Application.Calculation = xlCalculationManual
        Application.StatusBar = ">>>>>>>>Macro Is Running>>>>>>>>"
    Else
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        Application.Calculation = xlCalculationAutomatic
        Application.StatusBar = False
    End If
End Sub

Private Sub SetEdges(ByVal Rng As Range)
    With Rng
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        If .Cells.Count > 1 Then
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
            With .Borders(xlInsideHorizontal)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
        End If
    End With
End Sub