excel合并多个工作簿中的工作表

excel合并多个工作簿中的工作表

在同一文件夹中有多个工作簿，其中有一个用于汇总的工作簿，要求将除该汇总工作簿外的其它工作簿中的指定工作表的数据汇总到该汇总工作簿中。(这个最好用)代码如下：

Sub UnionWorksheets()

Application.ScreenUpdating = False

Dim lj As String

Dim dirname As String

Dim nm As String

lj = ActiveWorkbook.Path

nm =

dirname = Dir(lj & "\*.xls*")

Cells.Clear

Do While dirname <> ""

If dirname <> nm Then

Workbooks.Open Filename:=lj & "\" & dirname

Workbooks(nm).Activate

'复制新打开工作簿的第一个工作表的已用区域到当前工作表

Workbooks(dirname).Sheets(1).UsedRange.Copy _

Range("A65536").End(xlUp).Offset(1, 0)

'sheets(1) 中的1为工作表顺序号

Workbooks(dirname).Close False

End If

dirname = Dir

Loop

End Sub

可以将指定目录下的excel工作簿中的指定表！汇总到一起！

例如！将book1.xlsx中的sheet1。

book2.xlsx中的sheet1。

book3.xlsx中的sheet1。

book4.xlsx中的sheet1。

~~~~~~~~~~

合并到book汇总.xlsx中的sheet1中

如果你的建议是复制~~粘贴~就算了！这个我知道如何使用！

如果提供宏的朋友可以加入详细说明，以便我学习，我将酌情加分！

谢谢！

最佳答案

Sub Macro1()

Dim lj$, dirname$, nm$, wb As Workbook, sh As Worksheet, a, b

Set wb = ThisWorkbook

a = Array(0, 2, 1)

b = Array(0, -1, 0)

lj = ThisWorkbook.Path

nm =

dirname = Dir(lj & "\*.xls")

Application.ScreenUpdating = False

For Each sh In Sheets

edRange.Offset(3, 0).Clear

Next

Do While dirname <> ""

If dirname <> nm Then

With GetObject(lj & "\" & dirname)

For i = 1 To 2

If IsSheetEmpty = IsEmpty(.Sheets(i).UsedRange) Then _

.Sheets(i).UsedRange.Offset(3, 0).Copy wb.Sheets(.Sheets(i).Name).Cells(65536, a(i)).End(xlUp).Offset(1, b(i))

Next

.Close False

End With

End If

dirname = Dir

Loop

Dim UserSheet As Worksheet

Set UserSheet = ActiveSheet

Dim TopRow As Long

Dim LeftCol As Integer

TopRow = ActiveWindow.ScrollRow

LeftCol = ActiveWindow.ScrollColumn

Dim LastRow As Long, R As Long

LastRow = edRange.Rows.Count + edRange.Row - 1

Application.ScreenUpdating = False

For R = LastRow To 1 Step -1

If WorksheetFunction.CountA(Rows(R)) = 0 Then Rows(R).Delete

End If

Next R

UserSheet.Activate

ActiveWindow.ScrollRow = TopRow

ActiveWindow.ScrollColumn = LeftCol

Application.ScreenUpdating = True

MsgBox "工作表合并已经完毕", "0", "提示"

End Sub

Sub 合并当前目录下所有工作簿的全部工作表()

Dim MyPath, MyName, AWbName

Dim Wb As Workbook, WbN As String

Dim G As Long

Dim Num As Long

Dim BOX As String

Application.ScreenUpdating = False

MyPath = ActiveWorkbook.Path

MyName = Dir(MyPath & "\" & "*.xls")

AWbName =

Num = 0

Do While MyName <> ""

If MyName <> AWbName Then

Set Wb = Workbooks.Open(MyPath & "\" & MyName)

Num = Num + 1

With Workbooks(1).ActiveSheet

.Cells(.Range("B65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)

For G = 1 To Sheets.Count

Wb.Sheets(G).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)

Next

WbN = WbN & Chr(13) &

Wb.Close False

End With

End If

MyName = Dir

Loop

Range("B1").Select

Application.ScreenUpdating = True

MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"

End Sub