是给朋友整理实验数据用的,两个小需求:
一、要第一列是数据序号,且多个文件数据拷到目的文件的时候数据序号要按顺序排列;
二、每个文件可能有多个worksheet,都要拷贝到目标文件里面。
对于office2003以前的excel,是支持Application.FileSearch的,实现代码如下:
Sub Test()
Dim i As Integer,iRow As Integer Dim strPath As String Dim TheSheet As Worksheet iRow = 1 Set TheSheet = ActiveWorkbook.Worksheets("sheet1") strPath = "D:/Macro/testtest"
With Application.FileSearch .LookIn = strPath .SearchSubFolders = True .Filename = "*.*" If .Execute > 0 Then For i = 1 To .FoundFiles.Count 'Range("A" & i) = .FoundFiles(i) Workbooks.Open (.FoundFiles(i)) For j = 1 To ActiveWorkbook.Worksheets.Count 'ActiveWorkbook.Worksheets(i).Cells(1,1).Value = "a" ActiveWorkbook.Worksheets(j).UsedRange.Copy
TheSheet.Activate While TheSheet.Range("a" & iRow).Value <> "" TheSheet.Cells(iRow,1) = iRow iRow = iRow + 1 Wend
TheSheet.Range("A" & iRow).Select ActiveSheet.Paste ActiveWorkbook.Save
Next j
Workbooks(Workbooks.Count).Close Next i End If End With
End Sub
--------------------------------------------------------------------------------------
对于Office2007的用户,Application.FileSearch不支持了,修改后的代码如下:
Sub Test()
Dim i As Integer,iRow As Integer Dim strPath,Filename,Search_Fullname As String Dim TheSheet,CurrentSheet As Worksheet Dim Coll_Docs As New Collection Dim activeSheetName As String iRow = 1 Set TheSheet = ActiveWorkbook.Worksheets("sheet1") strPath = "D:/Macro/testtest" Filename = "*.xls" Set Coll_Docs = Nothing
DocName = Dir(strPath & "/" & Filename)
Do Until DocName = "" Coll_Docs.Add Item:=DocName DocName = Dir Loop
For i = Coll_Docs.Count To 1 Step -1 Search_Fullname = strPath & "/" & Coll_Docs(i) Workbooks.Open (Search_Fullname) For j = 1 To ActiveWorkbook.Worksheets.Count Step 1 If j = 1 Then activeSheetName = "sheet" & j Set CurrentSheet = ActiveWorkbook.Worksheets(activeSheetName) End If CurrentSheet.Activate ActiveWorkbook.Worksheets(j).UsedRange.Copy TheSheet.Activate While TheSheet.Range("a" & iRow).Value <> "" TheSheet.Cells(iRow,1) = iRow iRow = iRow + 1 Wend
TheSheet.Range("A" & iRow).Select ActiveSheet.Paste ActiveWorkbook.Save
Next j
Workbooks(Workbooks.Count).Close Next i
End Sub (编辑:李大同)
【声明】本站内容均来自网络,其相关言论仅代表作者个人观点,不代表本站立场。若无意侵犯到您的权利,请及时与联系站长删除相关内容!
|