对目录下所有的格式相同的EXCEL2003文件进行分表合并Sub 同目录分表合并()

'对目录下所有的格式相同的EXCEL2003文件进行分表合并

'注意每个工作表第一行有且为标题行,只复制第2行开始的数据

'原创精英网FookYou,二○○九年十一月一日zjxia889修改为通用宏

Dim Arr, MyPath$, MyName$, R&, Col%, aR_n&,shname

Dim Wb As Workbook '定义源文件,同目录下其它文件

Dim Ws As Worksheet '定义目标文件,当前文件

Dim F As Object

shname=activesheet.name   '定义合并的工作表名

Application.ScreenUpdating = False

MyPath = ActiveWorkbook.Path & "\"

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

For Each Ws In ActiveWorkbook.Sheets

'清除原有记录

Set F = Cells.Find("*", , , , , xlPrevious)

If Not F Is Nothing Then

Ws.Rows("2:" & F.Row + 1).Delete '多加一防止只有一行标题行时删除标题

End If

Next Ws

'逐个打开文件相同表名合并

Do While MyName <> ""

If MyName <> ActiveWorkbook.name Then '本文件不动作

Set Wb = GetObject(MyPath & MyName)

For Each Ws In Wb.Sheets

With Ws

if ws.name=shname then

Set F = .Cells.Find("*", , , , , xlPrevious) '求源文件最大行

If Not F Is Nothing Then

R = F.Row

If R > 1 Then '如果只有一行或空表不合并

Col = F.Column

Arr = .Range(.Cells(2, 1), .Cells(R, Col))

Set F = Sheets(Ws.name).Cells.Find("*", , , , , xlPrevious) '求目标文件最大行

If F Is Nothing Then

aR_n = 2

Else

aR_n = F.Row + 1

End If

Sheets(Ws.name).Cells(aR_n, 1).Resize(UBound(Arr), Col) = Arr

Sheets(Ws.name).Cells(aR_n, Col + 1).Resize(UBound(Arr)) = MyName '填充文件名

End If

End If

endif

End With

Next Ws

Wb.Close False

Set Wb = Nothing

Set Ws = Nothing

End If

MyName = Dir

Loop

Application.ScreenUpdating = True

End Sub