几个实用的Excel 宏代码

这段代码的作用：它会新建一个叫做“汇总”的工作表，然后把当前工作簿里的所有Sheet里有数据的内容都复制到“汇总”表里。提示：如果数据表里的内容没有表头的话需要把StartRow = 2改成StartRow = 1。

• Function LastRow(sh As Worksheet)  
•     On Error Resume Next  
•     LastRow = sh.Cells.Find(what:="*", _  
•                             After:=sh.Range("A1"), _  
•                             Lookat:=xlPart, _  
•                             LookIn:=xlFormulas, _  
•                             SearchOrder:=xlByRows, _  
•                             SearchDirection:=xlPrevious, _  
•                             MatchCase:=False).Row  
•     On Error GoTo 0  
• End Function  
•   
• Sub MergeSheets()  
•     Dim sh As Worksheet  
•     Dim DestSh As Worksheet  
•     Dim Last As Long  
•     Dim shLast As Long  
•     Dim CopyRng As Range  
•     Dim StartRow As Long  
•   
•     Application.ScreenUpdating = False  
•     Application.EnableEvents = False  
•   
•     '新建一个“汇总”工作表  
•     Application.DisplayAlerts = False  
•     On Error Resume Next  
•     ActiveWorkbook.Worksheets("汇总").Delete  
•     On Error GoTo 0  
•     Application.DisplayAlerts = True  
•     Set DestSh = ActiveWorkbook.Worksheets.Add  
•     DestSh.Name = "汇总"  
•   
•     '开始复制的行号，忽略表头，无表头请设置成1  
•     StartRow = 2  
•   
•     For Each sh In ActiveWorkbook.Worksheets  
•   
•         If sh.Name <> DestSh.Name Then  
•             Last = LastRow(DestSh)  
•             shLast = LastRow(sh)  
•   
•             If shLast > 0 And shLast >= StartRow Then  
•   
•                 Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))  
•   
•                 If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then  
•                     MsgBox "内容太多放不下啦！"  
•                     GoTo ExitSub  
•                 End If  
•   
•                 CopyRng.Copy  
•                 With DestSh.Cells(Last + 1, "A")  
•                     .PasteSpecial xlPasteValues  
•                     .PasteSpecial xlPasteFormats  
•                     Application.CutCopyMode = False  
•                 End With  
•             End If  
•         End If  
•     Next  
•   
• ExitSub:  
•     Application.GoTo DestSh.Cells(1)  
•     DestSh.Columns.AutoFit  
•     Application.ScreenUpdating = True  
•     Application.EnableEvents = True  
•      
• End Sub
  

多工作簿合并

这段代码的作用：它首先打开一个文件选择框，你可以选择一个或多个文件，然后把这些文件里的所有Sheet合并到当前这个工作簿里来，有重名的Sheet会自动在后面加数字。

1. Sub MergeWorkbooks()  
2.     Dim FileSet  
3.     Dim i As Integer  
4.      
5.     On Error GoTo 0  
6.     Application.ScreenUpdating = False  
7.   
8.     FileSet = Application.GetOpenFilename(FileFilter:="Excel 2003(*.xls),*.xls,Excel 2007(*.xlsx),*.xlsx", _  
9.                                             MultiSelect:=True, Title:="选择要合并的文件")  
10.      
11.     If TypeName(FileSet) = "Boolean" Then  
12.         GoTo ExitSub  
13.     End If  
14.      
15.     For Each Filename In FileSet  
16.         Workbooks.Open Filename  
17.         Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)  
18.     Next  
19.      
20. ExitSub:  
21.     Application.ScreenUpdating = True  
22.      
23. End Sub