Sub NextSeven20170706001()Application.ScreenUpdating = FalseApplication.DisplayAlerts = FalseApplication.Calculation = xlCalculationManualApplication.StatusBar = ">>>>>>>>程序正在运行>>>>>>>>"'On Error GoTo ErrHandlerDim StartTime, UsedTime As VariantStartTime = VBA.TimerDim wb As WorkbookDim OneSht As WorksheetDim Rng As RangeConst FirstRow As Long = 4Dim FormatRng As RangeDim Arr As VariantDim i As Long, j As LongDim PasteRow As LongDim DesRow As LongDim OpenWb As WorkbookDim OpenSht As WorksheetDim RngAdr As StringDim FilePath As StringDim High(1 To 8) As DoubleWith Application.FileDialog(msoFileDialogFilePicker).AllowMultiSelect = False.InitialFileName = ThisWorkbook.Path.Title = "请选择工资表！".Filters.Clear.Filters.Add "Excel工作簿", "*.xls*"If .Show = -1 ThenFilePath = .SelectedItems(1)Debug.Print FilePathElseMsgBox "您没有选中任何文件夹，本次汇总中断！"Exit SubEnd IfEnd WithSet wb = Application.ThisWorkbookSet OpenWb = Application.Workbooks.Open(FilePath)For Each OneSht In wb.WorksheetsRngAdr = RangeAddress(OneSht.Name)Set OpenSht = OpenWb.Worksheets(OneSht.Name)With OpenShtSet Rng = .UsedRangeArr = Rng.ValueEnd WithWith OneSht.UsedRange.Offset(8).ClearFor i = 1 To 8High(i) = .Cells(i, 1).RowHeightNext iSet FormatRng = .Range(RngAdr)For i = LBound(Arr) + 1 To UBound(Arr) - 1If i = 2 ThenFor j = LBound(Arr, 2) To UBound(Arr, 2).Cells(FirstRow, j + 1).Value = Arr(i, j)Next jElse'复制一次格式PasteRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row + 4FormatRng.Copy .Cells(PasteRow, 1)DesRow = PasteRow + 3For j = LBound(Arr, 2) To UBound(Arr, 2).Cells(DesRow, j + 1).Value = Arr(i, j)Next jEnd IfNext iEndRow = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).RowFor i = 1 To EndRowx = (i - 1) Mod 8 + 1.Rows(i).RowHeight = High(x)Next iEnd WithNext OneShtOpenWb.Close FalseSet wb = NothingSet OneSht = NothingSet FormatRng = NothingSet OpenWb = NothingSet OpenSht = NothingErrorExit:Set wb = NothingSet OneSht = NothingSet FormatRng = NothingSet OpenWb = NothingSet OpenSht = NothingApplication.ScreenUpdating = TrueApplication.DisplayAlerts = TrueApplication.Calculation = xlCalculationAutomaticApplication.StatusBar = FalseExit Sub'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
ErrHandler:If Err.Number <> 0 ThenMsgBox Err.Description & "！", vbCritical, "NextSeven Excel Studio QQ84857038"'Debug.Print Err.DescriptionErr.ClearResume ErrorExitEnd If
End SubFunction RangeAddress(ByVal SheetName As String) As StringSelect Case SheetNameCase "岗位工资制"RangeAddress = "A1:AG8"Case "叉车工资制"RangeAddress = "A1:AJ8"Case "产能工资制"RangeAddress = "A1:AH8"End Select
End Function