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