zoukankan      html  css  js  c++  java
  • 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
    

      

  • 相关阅读:
    android 本地字符串存取
    2020-07-17:线上一个服务有4个实例突然变得访问很慢,你会从什么地方入手找原因?
    2020-07-16:如何获得一个链表的倒数第n个元素?
    2020-07-15:死锁与活锁的区别,死锁与饥饿的区别?
    2020-07-14:es用过冷热分离吗?假如现在有些数据热变冷,有些数据冷变热,怎么解决?
    2020-07-28:已知sqrt (2)约等于 1.414,要求不用数学库,求sqrt (2)精确到小数点后 10 位。
    2020-07-29:从 innodb 的索引结构分析,为什么索引的 key 长度不能太长?
    2020-07-27:如何设计一个分布式文件系统,如何设计动态扩容和数据定位?
    2020-07-26:如何用 socket 编程实现 ftp 协议?
    2020-07-25:如何实现一个高效的单向链表逆序输出?
  • 原文地址:https://www.cnblogs.com/nextseven/p/7129149.html
Copyright © 2011-2022 走看看