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
