zoukankan      html  css  js  c++  java
  • 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
    

      

  • 相关阅读:
    苹果远程推送测试
    iOS 模糊化效果 ANBlurredImageView的使用
    VS2015中正确添加GIF的方式
    十大经典排序算法
    Windows Error Code(windows错误代码详解)
    C++捕获系统异常(VS2015设置)
    Qt5 error LNK2019 无法解析的外部符号的解决办法
    Linux常用命令大全(非常全!!!)
    利用MFC Picture Control控件 加载bmp,png
    在C++中如何实现文件的读写
  • 原文地址:https://www.cnblogs.com/nextseven/p/7191888.html
Copyright © 2011-2022 走看看