Public Sub CustomSubTotal()
AppSettings
On Error GoTo ErrHandler
Dim StartTime, UsedTime As Variant
StartTime = VBA.Timer
'Input code here
Dim i As Long, j As Long, k
Dim Wb As Workbook
Dim Sht As Worksheet
Dim oSht As Worksheet
Dim Dic As Object
Dim Arr As Variant
Dim Rng As Range
Set Dic = CreateObject("Scripting.Dictionary")
Dim SendDate$, Client$, Cargo$, Style$, Num#
Set Wb = Application.ThisWorkbook
Set Sht = Wb.Worksheets("数据表")
Set oSht = Wb.Worksheets("统计表")
With Sht
endrow = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row
Set Rng = .Range("A2:Z" & endrow)
Arr = Rng.Value
For i = LBound(Arr) To UBound(Arr)
SendDate = Format(CStr(Arr(i, 2)), "yyyy年mm月")
'Debug.Print mydate
Client = Arr(i, 4)
If Client = "" Then Client = "空"
Cargo = Arr(i, 5)
If Cargo = "" Then Cargo = "空"
Num = Arr(i, 10)
If InStr(1, Arr(i, 8), "，") > 0 Then
Style = Split(Arr(i, 8), "，")(0)
Else
Style = Arr(i, 8)
End If
'Debug.Print Style
Key = SendDate & ";" & Client & ";" & Cargo & ";" & Style
Dic(Key) = Dic(Key) + Num
Next i
End With
With oSht
.Cells.Clear
.Range("A1:E1").Value = Array("月份", "客户", "货品", "花色", "数量")
Arr = SubTotalDicToArr(Dic, ";")
.Range("A2").Resize(UBound(Arr), UBound(Arr, 2)).Value = Arr
CustomSort .Range("A1").CurrentRegion
SetEdges .Range("A1").CurrentRegion
End With
UsedTime = VBA.Timer - StartTime
Debug.Print "UsedTime：" & Format(UsedTime, "0.000 Seconds")
ErrorExit:
AppSettings False
Set Wb = Nothing
Set Sht = Nothing
Set oSht = Nothing
Set Rng = Nothing
Set Dic = Nothing
Exit Sub
ErrHandler:
If Err.Number <> 0 Then
MsgBox Err.Description & "！", vbCritical, "NextSeven QQ 84857038"
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
Public Function SubTotalDicToArr(ByVal Dic As Object, ByVal Separator As String) As Variant()
Dim Arr(), OneKey, Key$, Item$, iRow&, iCol&
Dim Keys, Items, m&, n&, KeyCount&, ItemCount&
iCol = 0
For Each OneKey In Dic.Keys
iCol = UBound(Split(OneKey, Separator)) + 1
iCol = iCol + UBound(Split(Dic(OneKey), Separator)) + 1
Exit For
Next OneKey
iRow = Dic.Count
ReDim Arr(1 To iRow, 1 To iCol)
m = 0
For Each OneKey In Dic.Keys
m = m + 1
Keys = Split(OneKey, Separator)
KeyCount = UBound(Keys) + 1
For n = 1 To KeyCount
Arr(m, n) = Keys(n - 1)
Next n
Items = Split(Dic(OneKey), Separator)
ItemCount = UBound(Items) + 1
For n = 1 To ItemCount
Arr(m, KeyCount + n) = Items(n - 1)
Next n
Next OneKey
SubTotalDicToArr = Arr
End Function
Private Sub SetEdges(ByVal Rng As Range)
With Rng
.HorizontalAlignment = xlCenter
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
Sub CustomSort(ByVal RngWithTitle As Range)
With RngWithTitle
.Sort Key1:=RngWithTitle.Cells(1, 1), Order1:=xlAscending, _
Key2:=RngWithTitle.Cells(1, 2), Order2:=xlAscending, Header:=xlYes, _
MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
End With
End Sub