VBA合并多个EXCEL-程序.docVIP

Option Explicit Sub mergeonexls() 合并多工作簿中指定工作表 On Error Resume Next Dim x As Variant, x1 As Variant, w As Workbook, wsh As Worksheet Dim t As Workbook, ts As Worksheet, l As Integer, h As Long Application.ScreenUpdating = False Application.DisplayAlerts = False x = Application.GetOpenFilename(FileFilter:=Excel文件 (*.xls; *.xlsx),*.xls; *.xlsx,所有文件(*.*),*.*, _ ?????? Title:=Excel选择, MultiSelect:=True) Set t = ThisWorkbook Set ts = t.Sheets(1) 指定合并到的工作表，这里是第一张工作表 l = ts.UsedRange.SpecialCells(xlCellTypeLastCell).Column For Each x1 In x If x1 False Then ?Set w = Workbooks.Open(x1) ?Set wsh = w.Sheets(1) 指定所需合并工作表，这里是第一张工作表 ?h = ts.UsedRange.SpecialCells(xlCellTypeLastCell).Row ?If l = 1 And h = 1 And ts.Cells(1, 1) = Then ?wsh.UsedRange.Copy ts.Cells(1, 1) ?Else ?wsh.UsedRange.Copy ts.Cells(h + 1, 1) ?End If ?w.Close End If Next Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub Sub mergeeveryonexls() 将多个工作簿下的工作表依次对应合并到本工作簿下的工作表，即第一张工作表对应合并到第一张，第二张对应合并到第二张…… On Error Resume Next Dim x As Variant, x1 As Variant, w As Workbook, wsh As Worksheet Dim t As Workbook, ts As Worksheet, i As Integer, l As Integer, h As Long Application.ScreenUpdating = False Application.DisplayAlerts = False x = Application.GetOpenFilename(FileFilter:=Excel文件 (*.xls; *.xlsx),*.xls; *.xlsx,所有文件(*.*),*.*, _ ?????? Title:=Excel选择, MultiSelect:=True) Set t = ThisWorkbook For Each x1 In x If x1 False Then ?Set w = Workbooks.Open(x1) ?For i = 1 To w.Sheets.Count If i t.Sheets.Count Then t.Sheets.Add After:=t.Sheets(t.Sheets.Count) ?Set ts = t.Sheets(i) ?Set wsh = w.Sheets(i) ?l = ts.UsedRange.SpecialCells(xlCellTypeLastCell).Column ?h = ts.UsedRange.SpecialCells(xlCellTypeLastCell).Row ?If l = 1 And h = 1 And ts.Cells(1, 1) = Then ?wsh.UsedRange.Copy ts.Cells(1, 1) ?Else ?wsh.UsedRange.Copy ts.Cells(h + 1, 1) ?End If ?Next ?w.Close End If Next Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub