Excel-VBA常用技巧代码.docxVIP

多个工作薄合并成同一个工作薄，如何合并？多人填一个同样的工作薄，形成了多个工作薄。如何让几人填了一部分的工作薄合并成终稿。Sub 汇总() Dim mypath As String, myname As String, Dname As String, sh As Workbook, copyrow As Integer Set sh = ThisWorkbook mypath = ThisWorkbook.Path myname = ThisWorkbook.Name Dname = Dir(mypath \*.xls) Application.ScreenUpdating = False Do While Dname If Dname myname Then copyrow = 1 With GetObject(mypath \ Dname) For i = 1 To .Worksheets.Count If .Sheets(i).Cells(5, 3) Then .Sheets(i).Rows(1: .Sheets(i).UsedRange.Rows.Count).Copy sh.Sheets(i).Cells(copyrow, 1) End If Next .Close False End With End If Dname = Dir Loop Application.ScreenUpdating = True MsgBox OK! End Sub合并工作簿：将其他工作簿的全部表合并到本工作Sub 合并工作簿() Dim FilesToOpen Dim x As Integer On Error GoTo ErrHandler Application.ScreenUpdating = False FilesToOpen = Application.GetOpenFilename _ (FileFilter:=Microsoft Excel Files (*.xls), *.xls, _ MultiSelect:=True, Title:=Files to Merge) If TypeName(FilesToOpen) = Boolean Then MsgBox No Files were selected GoTo ExitHandler End If x = 1 While x = UBound(FilesToOpen) Workbooks.Open Filename:=FilesToOpen(x) Sheets().Move After:=ThisWorkbook.Sheets _ (ThisWorkbook.Sheets.Count) x = x + 1 WendExitHandler: Application.ScreenUpdating = True Exit SubErrHandler: MsgBox Err.Description Resume ExitHandlerEnd SubSub 合并工作表()For Each st In WorksheetsIf st.Name ActiveSheet.Name Then st.UsedRange.Offset(1, 0).Copy [a65536].End(xlUp).Offset(1, 0)NextEnd SubSub 删除其他工作表()Dim arr()A = ActiveWorkbook.ActiveSheet.Nameicount = Sheets.CountFor i = 1 To icount t = Sheets(i).Name If t A Then r = r + 1 ReDim Preserve arr(1 To r) arr(r) = t End IfNextSheets(arr).SelectApplication.DisplayAlerts = FalseActiveWindow.SelectedSheets.DeleteApplication.DisplayAlerts = TrueEnd SubSub 清空本表() Cells.Select Selection.ClearContents Range(A1).SelectEnd SubSub 导出() Cells.Select Selection.Copy Workbooks.Add Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False ChDi