20170716xlVba销售明细转销售单据

Sub CreateSaleList()
    AppSettings

    On Error GoTo ErrHandler

    Dim StartTime As Variant    '开始时间
    Dim UsedTime As Variant    '使用时间
    StartTime = VBA.Timer    '记录开始时间

    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim oSht As Worksheet
    Dim NewSht As Worksheet
    Dim iRow As Long
    Dim NewRow As Long
    Dim Dic As Object
    Dim Key As String
    Dim PageNo As Long

    Set Wb = Application.ThisWorkbook

    For Each oSht In Wb.Worksheets
        If oSht.Name <> "明细" And oSht.Name <> "模板" Then
            Debug.Print oSht.Name
            oSht.Delete
        End If
    Next oSht

    Set Sht = Wb.Worksheets("明细")
    Set oSht = Wb.Worksheets("模板")

    Set Dic = CreateObject("Scripting.Dictionary")
    With Sht
        iRow = 3

        Do While .Cells(iRow, 1).Value <> ""
            Key = .Cells(iRow, 1).Value
            Dic(Key) = Dic(Key) + 1
            PageNo = Int((Dic(Key) - 1) / 5) + 1
            NewName = Key & "(" & PageNo & ")"
            If Dic(Key) Mod 5 = 1 Then
                '  On Error Resume Next
                '  Wb.Worksheets(NewName).Delete
                '  On Error GoTo 0
                oSht.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").Value
                NewSht.Range("E3").Value = .Cells(iRow, "B").Value
                NewSht.Range("G2").Value = NewSht.Range("G2").Value & .Cells(iRow, "A").Value
                NewSht.Range("G3").Value = NewSht.Range("G3").Value & .Cells(iRow, "L").Value
            End If

            NewRow = 4 + (Dic(Key) - 1) Mod 5 + 1

            NewSht.Cells(NewRow, 1).Value = .Cells(iRow, 6).Value
            NewSht.Cells(NewRow, 2).Value = .Cells(iRow, 7).Value
            NewSht.Cells(NewRow, 3).Value = .Cells(iRow, 8).Value
            NewSht.Cells(NewRow, 4).Value = .Cells(iRow, 11).Value
            NewSht.Cells(NewRow, 5).Value = .Cells(iRow, 10).Value
            NewSht.Cells(NewRow, 6).Value = .Cells(iRow, 13).Value
            NewSht.Cells(NewRow, 7).Value = .Cells(iRow, 9).Value

            iRow = iRow + 1
            If iRow = 60 Then Exit Do  '防止死循环
        Loop
    End With

    Set Wb = Nothing
    Set Sht = Nothing
    Set oSht = Nothing
    Set NewSht = Nothing

    AppSettings False

    UsedTime = VBA.Timer - StartTime
    MsgBox "本次运行耗时：" & Format(UsedTime, "#0.0000秒")
ErrorExit:
    AppSettings False
    Exit Sub
ErrHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Description & "！", vbCritical, "QQ 84857038"
        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