20170617xlVBA Sales Data subtotals

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 Di M ARR as Variant const head_row as Long = 5 Const sheet_name As String = "Subtotal" 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 Clien T As String ' Customer name Dim bookno As String ' order number Dim status As String ' state Dim item As String ' Statistic item Dim DC Lient As Object Dim Dbookinfo As Object Dim Mixkey As String Dim Key As String Dim Tmpkey As String Dim one Client Dim Index as Long set dbookno = CreateObject ("Scripting.Dictionary") Set Dbookinfo = CreateObject ("Scripti Ng.    Dictionary ")Set dclient = CreateObject ("Scripting.Dictionary") Set Wb = Application.thisworkbook Set Sht = Wb.worksheets (SHEET_N AME) with Sht. Usedrange.offset (Head_row). ClearContents dataname =. Range ("L2").    Value End with If dataname = "Then MsgBox" Please enter the query range! ", vbinformation," QQ "GoTo errorexit End If        If dataname <> "all year" then ' Judge a month! On Error Resume Next Set Osht = wb.worksheets (dataname) If Osht are Nothing Then MsgBox "Entered month (worksheet Name) wrong, please re-enter! ", vbinformation," QQ "GoTo errorexit End If with Osht Endro W =. 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 Uboun D (arr) client = CSTR (arr (i, 2)) ' Customer Name Bookno = CStr (arr (i, 1)) Status = CS TR (ArR (I, 6)) ' Progress status dclient (client) = ' "' Save all customer names Mixkey = client &"; "& Bookno & Amp ";" & Status Key = client & ";" & Status ' customer, status If dbookno.exists (mixkey) = F Alse then ' prevent duplicate Tmpkey = Key &; ' & ' Order volume ' dbookcount (tmpkey) = Dbookco UNT (Tmpkey) + 1 dbookinfo (Tmpkey) = Dbookinfo (Tmpkey) + 1 dbookno (Mixkey) = "" Place order number to prevent duplicate End If Tmpkey = Key & ";" & "Order Amount" dbookinfo (tmpkey) = Dboo Kinfo (Tmpkey) + ARR (i, n) tmpkey = Key & ";" & "Received Amount" dbookinfo (tmpkey) = Dbookinf O (tmpkey) + ARR (i, +) Tmpkey = Key & ";" & "Outbound Amount" dbookinfo (tmpkey) = Dbookinfo (Tmp  Key) + ARR (i, +) Tmpkey = Key & ";" & "Amount not Receivable" dbookinfo (tmpkey) = Dbookinfo (Tmpkey)      + ARR (i, 15)      Next i End with Else for each osht in wb.worksheets If osht.name like "* Month" 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)) ' Customer Name Bookno = CS TR (arr (i, 1)) status = CStr (arr (i, 6)) ' Progress status dclient (Client) = ' "' Save Client name Mixkey = client & ";" & Bookno & ";" & Status Key = Cl                            Ient & ";" & Status ' Customer, State If dbookno.exists (mixkey) = False Then ' prevent duplicates                          Tmpkey = Key & ";" & "Order Quantity"  ' Dbookcount (Tmpkey) = Dbookcount (Tmpkey) + 1 dbookinfo (Tmpkey) = Dbookinfo (Tmpkey) + 1 Dbookno (Mixkey) = "" ' Write down order number to prevent repeat End If Tmpkey = Ke                        Y & ";" & "Order Amount" dbookinfo (tmpkey) = Dbookinfo (Tmpkey) + ARR (i, 12)                        Tmpkey = Key & ";" & "Receivable Amount" dbookinfo (tmpkey) = Dbookinfo (Tmpkey) + ARR (i, 13)                        Tmpkey = Key & ";" & "Outbound Amount" dbookinfo (tmpkey) = Dbookinfo (Tmpkey) + ARR (i, 14)  Tmpkey = Key & ";" & "Amount not Receivable" dbookinfo (tmpkey) = Dbookinfo (Tmpkey) +        ARR (i, i) 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 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 appli cation. Intersect (. Usedrange.offset (Head_row),. UsedRange) End with usedtime = VBA. Timer-starttime Debug.Print "Usedtime:" & Format (Usedtime, "0.000 Seconds") ' MsgBox ' usedtime: ' & Format (U Sedtime, "0.000 Seconds"), vbOKOnly, "Nextseven QQ" errorexit:appsettings False Exit suberrhandler:if err.numb Er <> 0 Then MsgBox err.description & "! ", vbcritical," Nextseven "Debug.Print err.description err.clear Resume errorexit End ifend Subpu Blic Sub APpsettings (Optional isstart as Boolean = True) If Isstart then application.screenupdating = False Applica tion. DisplayAlerts = False Application.calculation = xlcalculationmanual Application.statusbar = ">>>&gt        ; >>>>macro is running>>>>>>>> "Else application.screenupdating = True Application.DisplayAlerts = True Application.calculation = xlcalculationautomatic Application.statusbar = F Alse End IfEnd SubPrivate Sub setedges (ByVal rng as Range) with Rng. 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 WithEnd Sub

　　

20170617xlVBA Sales Data subtotals