Public Sub Basic_CodeFrame() AppSettings On Error GoTo ErrHandler Dim StartTime, UsedTime As Variant StartTime = VBA.Timer 'Input code here Call SubTotalData UsedTime = VBA.Timer - StartTime 'Debug.Print "UsedTime:" & Format(UsedTime, "0.000 Seconds") MsgBox "UsedTime:" & Format(UsedTime, "0.000 Seconds"), vbOKOnly, "NS QQ " ErrorExit: AppSettings False Exit Sub ErrHandler: If Err.Number <> 0 Then MsgBox Err.Description & "!", vbCritical, "NextSeven QQ " 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 SubTotalData() Dim dShtName As Object Dim dInfo As Object Dim Key As String Dim OneKey Const MAIN_SHEET As String = "分类汇总表" Const SALE_SHEET As String = "销售数据汇总表" Const PROC_SHEET As String = "生产入库明细表" Const STORE_SHEET As String = "汇总后库存明细表" Const HEAD_ROW As Long = 3 Const END_COL As String = "Z" Dim EndRow As Long Dim Wb As Workbook Dim Sht As Worksheet Dim oSht As Worksheet Dim Rng As Range Dim Arr As Variant Dim Data() As Variant Set Wb = Application.ThisWorkbook Set Sht = Wb.Worksheets(MAIN_SHEET) Set dShtName = CreateObject("Scripting.Dictionary") Set dInfo = CreateObject("Scripting.Dictionary") Key = MAIN_SHEET dShtName(Key) = "" Key = SALE_SHEET dShtName(Key) = "" Key = PROC_SHEET dShtName(Key) = "" Key = STORE_SHEET dShtName(Key) = "" For Each oSht In Wb.Worksheets If dShtName.EXISTS(oSht.Name) = False Then With oSht EndRow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row Set Rng = .Range(.Cells(HEAD_ROW + 1, "A"), .Cells(EndRow, END_COL)) Arr = Rng.Value For i = LBound(Arr) To UBound(Arr) Key = CStr(Arr(i, 3)) Item = CStr(Arr(i, 3)) & ";" & CStr(Arr(i, 4)) & _ ";" & CStr(Arr(i, 5)) & ";" & CStr(Arr(i, 6)) 'Debug.Print Item dInfo(Key) = Item Next i End With End If Next oSht ReDim Data(1 To 14, 1 To 1) Dim Index As Long Dim PlanIndex As Long Dim SaleIndex As Long Dim ProcIndex As Long Dim StoreIndex As Long Index = 0 PlanIndex = Index SaleIndex = Index ProcIndex = Index StoreIndex = Index For Each OneKey In dInfo.keys Key = OneKey '循环所有部门工作表 For Each oSht In Wb.Worksheets If dShtName.EXISTS(oSht.Name) = False Then With oSht EndRow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row Set Rng = .Range(.Cells(HEAD_ROW + 1, "A"), .Cells(EndRow, END_COL)) Arr = Rng.Value For i = LBound(Arr) To UBound(Arr) If CStr(Arr(i, 3)) = Key Then PlanIndex = PlanIndex + 1 '计划生产部分 ReDim Preserve Data(1 To 14, 1 To PlanIndex) info = Split(dInfo(Key), ";") For n = LBound(info) To UBound(info) Data(n + 1, PlanIndex) = info(n) Next n Data(5, PlanIndex) = Format(Arr(i, 1), "yyyy/mm/dd") '日期 Data(6, PlanIndex) = Arr(i, 8) Data(7, PlanIndex) = Arr(i, 2) End If Next i End With End If Next oSht Index = Application.WorksheetFunction.Max(PlanIndex, SaleIndex, ProcIndex, StoreIndex) '保存最大行号 Set oSht = Wb.Worksheets(PROC_SHEET) With oSht EndRow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row Set Rng = .Range(.Cells(HEAD_ROW + 1, "A"), .Cells(EndRow, END_COL)) Arr = Rng.Value For i = LBound(Arr) To UBound(Arr) If CStr(Arr(i, 15)) = Key Then ProcIndex = ProcIndex + 1 '计划生产部分 '重定义数组 If ProcIndex > Index Then ReDim Preserve Data(1 To 14, 1 To ProcIndex) info = Split(dInfo(Key), ";") For n = LBound(info) To UBound(info) Data(n + 1, ProcIndex) = info(n) Next n Data(8, ProcIndex) = Format(Arr(i, 4), "yyyy/mm/dd") '日期 Data(9, ProcIndex) = Arr(i, 19) Data(10, ProcIndex) = Arr(i, 13) End If Next i End With Index = Application.WorksheetFunction.Max(PlanIndex, SaleIndex, ProcIndex, StoreIndex) '保存最大行号 Set oSht = Wb.Worksheets(SALE_SHEET) With oSht EndRow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row Set Rng = .Range(.Cells(HEAD_ROW + 1, "A"), .Cells(EndRow, END_COL)) Arr = Rng.Value For i = LBound(Arr) To UBound(Arr) If CStr(Arr(i, 17)) = Key Then SaleIndex = SaleIndex + 1 '计划生产部分 '重定义数组 If SaleIndex > Index Then ReDim Preserve Data(1 To 14, 1 To SaleIndex) info = Split(dInfo(Key), ";") For n = LBound(info) To UBound(info) Data(n + 1, SaleIndex) = info(n) Next n Data(11, SaleIndex) = Arr(i, 6) Data(12, SaleIndex) = Arr(i, 21) End If Next i End With Index = Application.WorksheetFunction.Max(PlanIndex, SaleIndex, ProcIndex, StoreIndex) '保存最大行号 Set oSht = Wb.Worksheets(STORE_SHEET) With oSht EndRow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row Set Rng = .Range(.Cells(HEAD_ROW + 1, "A"), .Cells(EndRow, END_COL)) Arr = Rng.Value For i = LBound(Arr) To UBound(Arr) If CStr(Arr(i, 2)) = Key Then StoreIndex = StoreIndex + 1 '计划生产部分 '重定义数组 If StoreIndex > Index Then ReDim Preserve Data(1 To 14, 1 To StoreIndex) info = Split(dInfo(Key), ";") For n = LBound(info) To UBound(info) Data(n + 1, StoreIndex) = info(n) Next n Data(13, StoreIndex) = Arr(i, 6) Data(14, StoreIndex) = Format(Arr(i, 4), "yyyy/mm/dd") End If Next i End With '再次初始化 Index = Application.WorksheetFunction.Max(PlanIndex, SaleIndex, ProcIndex, StoreIndex) '保存最大行号 PlanIndex = Index SaleIndex = Index ProcIndex = Index StoreIndex = Index Next OneKey Index = Application.WorksheetFunction.Max(PlanIndex, SaleIndex, ProcIndex, StoreIndex) With Sht .UsedRange.Offset(2).Clear Set Rng = .Range("A3").Resize(Index, 14) Rng.Value = Application.WorksheetFunction.Transpose(Data) '输出数组 MergeSameItem .UsedRange '合并同项 SetEdges .UsedRange '设置居中与边框 End With End Sub Private Sub MergeSameItem(ByVal RngWithTitle As Range) '禁止合并单元格过程中出现警告提示 Application.DisplayAlerts = False Dim i As Integer Dim RowCount As Long Dim LastRow As Long Dim FirstRow As Long With RngWithTitle '根据A列序号合并A列 RowCount = .Cells.Rows.Count LastRow = RowCount For i = RowCount To 2 Step -1 If .Cells(i, "A").Value <> .Cells(i - 1, "A").Value Then '若前后行内容不同 FirstRow = i '记下合并区域的起始行 .Cells(FirstRow, "A").Resize(LastRow - FirstRow + 1, 1).Merge '拓展选区 .Cells(FirstRow, "B").Resize(LastRow - FirstRow + 1, 1).Merge '拓展选区 .Cells(FirstRow, "C").Resize(LastRow - FirstRow + 1, 1).Merge '拓展选区 .Cells(FirstRow, "D").Resize(LastRow - FirstRow + 1, 1).Merge '拓展选区 LastRow = i - 1 '调整下一个区域的终止行 End If Next i End With Application.DisplayAlerts = True '恢复警告提示 End Sub Private Sub SetEdges(ByVal Rng As Range) With Rng .HorizontalAlignment = xlCenter .VerticalAlignment = 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