excel合并工作簿和工作表的代碼

1、把多個(gè)工作簿合并到一個(gè)工作簿作為新工作簿的一張表(宏代碼)Sub 合并當(dāng)前目錄下所有工作簿的全部工作表 ()Dim MyPath, MyName, AWbNameDim Wb As Workbook, WbN As StringDim G As LongDim Num As LongDim BOX As StringApplication.ScreenUpdating = FalseMyPath = ActiveWorkbook.PathMyName = Dir(MyPath & "" & "*.xls")AWbName = Active

2、Workbook.NameNum = 0Do While MyName <> ""If MyName <> AWbName ThenSet Wb = Workbooks.Open(MyPath & "" & MyName)Num = Num + 1With Workbooks(1).ActiveSheet.Cells(.Range("A65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)For G = 1 To Sheets.

3、CountWb.Sheets(G).UsedRange.Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 1)NextWbN = WbN & Chr(13) & Wb.NameWb.Close FalseEnd WithEnd IfMyName = DirLoopRange("A1").SelectApplication.ScreenUpdating = TrueMsgBox "共合并了 " & Num & " 個(gè)工作薄下的全部工作表。如下： &q

4、uot; & Chr(13) & WbN, vbInformation, " 提示 "End Sub具體操作：在工作簿目錄下新建一工作簿，工具-宏 編輯器 插入模塊-粘貼代碼 =運(yùn)行excel 如何將一個(gè)工作簿中的多個(gè)工作表合并到一張工作表上打開(kāi)你的工作簿 新建一個(gè)工作表 在這個(gè)工作表的標(biāo)簽上右鍵 查看代碼 你把下面 的代碼復(fù)制到里邊去，然后 上面有個(gè)運(yùn)行 運(yùn)行子程序就可以了，代碼如下，如果 出現(xiàn) 問(wèn)題你可以嘗試工具 宏 宏安全性里把那個(gè)降低為中或者低再試試Sub 合并當(dāng)前工作簿下的所有工作表 ()Application.ScreenUpdating = F

5、alseFor j = 1 To Sheets.CountIf Sheets(j).Name <> ActiveSheet.Name ThenX = Range("A65536").End(xlUp).Row + 1Sheets(j).UsedRange.Copy Cells(X, 1)End IfNextRange("B1").SelectApplication.ScreenUpdating = TrueMsgBox " 當(dāng)前工作簿下的全部工作表已經(jīng)合并完畢！", vbInformation, " 提示 &qu

6、ot;End Sub把同一工作簿多張工作表合并到同一張工作表1 新建一個(gè)工作表放在最左邊， ALT + F11 鍵打開(kāi)代碼框 -插入-模塊 -復(fù)制以 下代碼ALT + F8 鍵打開(kāi)，運(yùn)行該代碼即可Sub 合并 ()For I = 2 To Sheets.Count '如果工作表的第一行都一樣，就把下面 Rows("1" &的 1 改成 2 就好了Sheets(I).Rows("1" & ":" & Sheets(I).Range("A60000").End(xlUp).Row). _

7、Copy Range("A" & Range("A60000").End(xlUp).Row + 1)NextEnd Sub批量將多個(gè) excel 中的多個(gè)工作簿合并到一個(gè) excel 中將要合并的excel放到一個(gè)文件夾中，在這個(gè)目錄中新建一個(gè)excel,運(yùn)行以下代碼As StringAs StringAs RangeAs WorkbookAs WorksheetAs StringSub CombineFiles() Dim pathDim FileNameDim LastCellDim WkbDim WSDim ThisWBDim MyDir

8、 As StringMyDir = ThisWorkbook.path & ""'ChDrive Left(MyDir, 1) 'find all the excel files 'ChDir MyDir'Match = Dir$("")ThisWB = ThisWorkbook.NameApplication.EnableEvents = FalseApplication.ScreenUpdating = Falsepath = MyDirFileName = Dir(path & "*.xls

9、", vbNormal)Do Until FileName = ""If FileName <> ThisWB ThenSet Wkb = Workbooks.Open(FileName:=path & "" & FileName)For Each WS In Wkb.WorksheetsSet LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell)If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then ElseWS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) End IfNext WSWkb