zoukankan      html  css  js  c++  java
  • 20170706xlVBA根据工资汇总表生成个人工资条

    Sub NextSeven20170706001()
        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 OneSht As Worksheet
        Dim Rng As Range
        Const FirstRow As Long = 4
        Dim FormatRng As Range
        Dim Arr As Variant
        Dim i As Long, j As Long
        Dim PasteRow As Long
        Dim DesRow As Long
        Dim OpenWb As Workbook
        Dim OpenSht As Worksheet
    
        Dim RngAdr As String
        Dim FilePath As String
        Dim High(1 To 8) As Double
    
    
    
        With Application.FileDialog(msoFileDialogFilePicker)
            .AllowMultiSelect = False
            .InitialFileName = ThisWorkbook.Path
            .Title = "请选择工资表!"
            .Filters.Clear
            .Filters.Add "Excel工作簿", "*.xls*"
            If .Show = -1 Then
                FilePath = .SelectedItems(1)
                Debug.Print FilePath
            Else
                MsgBox "您没有选中任何文件夹,本次汇总中断!"
                Exit Sub
            End If
        End With
    
    
    
        Set wb = Application.ThisWorkbook
        Set OpenWb = Application.Workbooks.Open(FilePath)
        For Each OneSht In wb.Worksheets
            RngAdr = RangeAddress(OneSht.Name)
            Set OpenSht = OpenWb.Worksheets(OneSht.Name)
            With OpenSht
                Set Rng = .UsedRange
                Arr = Rng.Value
            End With
            With OneSht
                .UsedRange.Offset(8).Clear
                For i = 1 To 8
                    High(i) = .Cells(i, 1).RowHeight
                Next i
    
                Set FormatRng = .Range(RngAdr)
                For i = LBound(Arr) + 1 To UBound(Arr) - 1
    
                    If i = 2 Then
                        For j = LBound(Arr, 2) To UBound(Arr, 2)
                            .Cells(FirstRow, j + 1).Value = Arr(i, j)
                        Next j
                    Else
                        '复制一次格式
                        PasteRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row + 4
                        FormatRng.Copy .Cells(PasteRow, 1)
                        DesRow = PasteRow + 3
    
                        For j = LBound(Arr, 2) To UBound(Arr, 2)
                            .Cells(DesRow, j + 1).Value = Arr(i, j)
                        Next j
    
    
                    End If
                Next i
    
                EndRow = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row
    
                For i = 1 To EndRow
                    x = (i - 1) Mod 8 + 1
                    .Rows(i).RowHeight = High(x)
                Next i
            End With
    
        Next OneSht
    
        OpenWb.Close False
    
        Set wb = Nothing
        Set OneSht = Nothing
        Set FormatRng = Nothing
        Set OpenWb = Nothing
        Set OpenSht = Nothing
    
    
    
    
    ErrorExit:
        Set wb = Nothing
        Set OneSht = Nothing
        Set FormatRng = Nothing
        Set OpenWb = Nothing
        Set OpenSht = 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, "NextSeven Excel Studio QQ84857038"
            'Debug.Print Err.Description
            Err.Clear
            Resume ErrorExit
        End If
    End Sub
    
    
    Function RangeAddress(ByVal SheetName As String) As String
        Select Case SheetName
        Case "岗位工资制"
            RangeAddress = "A1:AG8"
        Case "叉车工资制"
            RangeAddress = "A1:AJ8"
        Case "产能工资制"
            RangeAddress = "A1:AH8"
        End Select
    End Function
    

      

  • 相关阅读:
    (hdu step 7.1.2)You can Solve a Geometry Problem too(乞讨n条线段,相交两者之间的段数)
    阅读&lt;反欺骗的艺术&gt;思考
    顺序查找(改进)
    win7电脑那些事
    激活office 2010
    MyEclipse10安装SVN插件
    合并排序法
    希尔排序法
    直接插入排序法
    快速排序法——较优方法
  • 原文地址:https://www.cnblogs.com/nextseven/p/7126038.html
Copyright © 2011-2022 走看看