Public Sub NextSeven_CodeFrame()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.StatusBar = ">>>>>>>>程序正在运行>>>>>>>>" On Error GoTo ErrHandler Dim StartTime, UsedTime As Variant
StartTime = VBA.Timer
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Dim Wb As Workbook
Dim Sht As Worksheet
Dim OpenWb As Workbook
Dim OneSht As Worksheet Dim Arr As Variant
Dim i As Long Dim FolderPath As String
Dim FileName As String
Dim FileCount As Long Dim OneKey
Dim Key As String
Dim Dic As Object Set Dic = CreateObject("Scripting.Dictionary") '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Set Wb = Application.ThisWorkbook
Set Sht = Wb.Worksheets("分类汇总") FolderPath = Wb.Path & Application.PathSeparator
FileCount = 0
FileName = Dir(FolderPath & "*.xls*")
Do While FileName <> ""
If FileName <> ThisWorkbook.Name Then
FileCount = FileCount + 1
Set OpenWb = Application.Workbooks.Open(FolderPath & FileName)
With OpenWb
For Each OneSht In .Worksheets
If OneSht.Name Like "*月" Then
With OneSht
endrow = .Cells(.Cells.Rows.Count, "B").End(xlUp).Row
Set Rng = .Range("A3:F" & endrow)
Arr = Rng.Value
For i = LBound(Arr) To UBound(Arr)
Key = .Name & ";" & CStr(Arr(i, 2) & ";" & Arr(i, 3))
Dic(Key) = Dic(Key) + Arr(i, 4)
Next i
End With
End If
Next OneSht
.Close False
End With
End If
FileName = Dir
Loop With Sht
.Cells.Clear
.Range("A1:D1").Value = Array("月份", "型号与品名", "工序", "总数")
i = 1
For Each OneKey In Dic.Keys
i = i + 1
Key = CStr(OneKey)
.Cells(i, 1).Value = Split(Key, ";")(0)
.Cells(i, 2).Value = Split(Key, ";")(1)
.Cells(i, 3).Value = Split(Key, ";")(2)
.Cells(i, 4).Value = Dic(OneKey)
Next OneKey
SetEdges .UsedRange
End With '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
UsedTime = VBA.Timer - StartTime
MsgBox "本次耗时：" & Format(UsedTime, "0.000秒"), vbOKOnly, "Tips" ErrorExit:
Set Wb = Nothing
Set Sht = Nothing
Set OpenWb = Nothing
Set OneSht = Nothing
Set Rng = Nothing Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
Exit Sub
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
ErrHandler:
If Err.Number <> 0 Then
MsgBox Err.Description & "！", vbCritical, "Tips"
'Debug.Print Err.Description
Err.Clear
Resume ErrorExit
End If
End Sub