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