Sub CreateSaleList()AppSettingsOn Error GoTo ErrHandlerDim StartTime As Variant    '开始时间Dim UsedTime As Variant    '使用时间StartTime = VBA.Timer    '记录开始时间Dim Wb As WorkbookDim Sht As WorksheetDim oSht As WorksheetDim NewSht As WorksheetDim iRow As LongDim NewRow As LongDim Dic As ObjectDim Key As StringDim PageNo As LongSet Wb = Application.ThisWorkbookFor Each oSht In Wb.WorksheetsIf oSht.Name <> "明细" And oSht.Name <> "模板" ThenDebug.Print oSht.NameoSht.DeleteEnd IfNext oShtSet Sht = Wb.Worksheets("明细")Set oSht = Wb.Worksheets("模板")Set Dic = CreateObject("Scripting.Dictionary")With ShtiRow = 3Do While .Cells(iRow, 1).Value <> ""Key = .Cells(iRow, 1).ValueDic(Key) = Dic(Key) + 1PageNo = Int((Dic(Key) - 1) / 5) + 1NewName = Key & "(" & PageNo & ")"If Dic(Key) Mod 5 = 1 Then'  On Error Resume Next'  Wb.Worksheets(NewName).Delete'  On Error GoTo 0oSht.Copy After:=Wb.Worksheets(Wb.Worksheets.Count)Set NewSht = Wb.Worksheets(Wb.Worksheets.Count)NewSht.Name = Key & "(" & PageNo & ")"NewSht.Range("B3").Value = .Cells(iRow, "C").ValueNewSht.Range("E3").Value = .Cells(iRow, "B").ValueNewSht.Range("G2").Value = NewSht.Range("G2").Value & .Cells(iRow, "A").ValueNewSht.Range("G3").Value = NewSht.Range("G3").Value & .Cells(iRow, "L").ValueEnd IfNewRow = 4 + (Dic(Key) - 1) Mod 5 + 1NewSht.Cells(NewRow, 1).Value = .Cells(iRow, 6).ValueNewSht.Cells(NewRow, 2).Value = .Cells(iRow, 7).ValueNewSht.Cells(NewRow, 3).Value = .Cells(iRow, 8).ValueNewSht.Cells(NewRow, 4).Value = .Cells(iRow, 11).ValueNewSht.Cells(NewRow, 5).Value = .Cells(iRow, 10).ValueNewSht.Cells(NewRow, 6).Value = .Cells(iRow, 13).ValueNewSht.Cells(NewRow, 7).Value = .Cells(iRow, 9).ValueiRow = iRow + 1If iRow = 60 Then Exit Do  '防止死循环LoopEnd WithSet Wb = NothingSet Sht = NothingSet oSht = NothingSet NewSht = NothingAppSettings FalseUsedTime = VBA.Timer - StartTimeMsgBox "本次运行耗时：" & Format(UsedTime, "#0.0000秒")
ErrorExit:AppSettings FalseExit Sub
ErrHandler:If Err.Number <> 0 ThenMsgBox Err.Description & "！", vbCritical, "QQ 84857038"Debug.Print Err.DescriptionErr.ClearResume ErrorExitEnd IfEnd SubPublic Sub AppSettings(Optional IsStart As Boolean = True)If IsStart ThenApplication.ScreenUpdating = FalseApplication.DisplayAlerts = FalseApplication.Calculation = xlCalculationManualApplication.StatusBar = ">>>>>>>>Macro Is Running>>>>>>>>"ElseApplication.ScreenUpdating = TrueApplication.DisplayAlerts = TrueApplication.Calculation = xlCalculationAutomaticApplication.StatusBar = FalseEnd If
End Sub