收到很多Excel文档,需要把它们组合在一起形成一张大表,然后才进行格式化。
由于文档格式有些差异,合并最好的办法只能是复制、粘贴,为提高效率,特编此VBA:
Sub MergeWorkbooks() Dim i As Long Dim WB As Workbook Dim currentWS As Worksheet Set currentWS = ActiveSheet Application.DisplayAlerts = False With Application.FileDialog(msoFileDialogOpen) .Filters.Clear .Filters.Add "Excel", "*.xls", 1 .AllowMultiSelect = True .Show For i = 1 To .SelectedItems.Count Set WB = Workbooks.Open(.SelectedItems(i)) MyUsedRange Selection.Copy currentWS.Activate ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Select Cells(Selection.Row + 1, 1).Select ActiveSheet.Paste WB.Close Next i End With Application.DisplayAlerts = TrueEnd Sub
Sub MyUsedRange()Dim ar As Range, r As Double, c As Integer, tr As Double, tc As IntegerDim ur As Range, fr As Double, fc As Integer, tfr As Double, tfc As Integer
On Error Resume Next fc = ActiveSheet.Columns.Count fr = ActiveSheet.Rows.Count Set ur = Union(ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants), _ ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas)) If Err.Number = 1004 Then Err.Clear Set ur = ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants) End If If Err.Number = 1004 Then Err.Clear Set ur = ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas) End If If Err.Number = 0 Then For Each ar In ur.Areas tr = ar.Range("A1").Row + ar.Rows.Count - 1 tc = ar.Range("A1").Column + ar.Columns.Count - 1 If tc > c Then c = tc If tr > r Then r = tr tfr = ar.Range("A1").Row tfc = ar.Range("A1").Column If tfc < fc Then fc = tfc If tfr < fr Then fr = tfr Next Range(Cells(fr, fc), Cells(r, c)).Select ElseIf Err.Number = 1004 Then Range("A1").Select End IfEnd Sub
如此把选中文档(可以多个)的当前sheet拷贝到vba执行时的活动sheet中,并向下平铺。
MyUsedRange子程序摘自微软http://support.microsoft.com/default.aspx?scid=kb%3Bzh-cn%3B232094
感觉比Excel自带的UsedRange好用。 |