| 對目錄下所有的格式相同的EXCEL2003文件進行分表合并Sub 同目錄分表合并()
'對目錄下所有的格式相同的EXCEL2003文件進行分表合并
'注意每個工作表第一行有且為標題行,只復制第2行開始的數(shù)據(jù)
'原創(chuàng)精英網(wǎng)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
|
| | | |
|
