用VB把多个excel文件的数据顺序拷到一个excel中

是给朋友整理实验数据用的，两个小需求：

一、要第一列是数据序号，且多个文件数据拷到目的文件的时候数据序号要按顺序排列；

二、每个文件可能有多个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