20170617xlVBA銷售數據分類匯總
阿新 • • 發佈:2017-07-07
tin object pda address class otto 防止 nec arr
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
20170617xlVBA銷售數據分類匯總