vb整合多个excel表格到一张_用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