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