求助：用VBA把文件夹下所有excel表集中在一个文件中

Question

文件夹下有几十个excel文件，我想一次性把这些文件中的sheet1都复制在一个文件中，sheet名为原来的文件名，代码应该怎么写？

Answer 1

看起来有点长，但不需要修改：
Sub copysheet1()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
BkName = ActiveWorkbook.Name
For i = Sheets.Count To 2 Step -1
Sheets(i).Delete
Next i
MsgBox "请选择 Excel文件 的路径！"
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
folderspec = .SelectedItems(1)
If Right(SavePath, 1) <> "\" Then
folderspec = folderspec + "\"
End If
End With
Dim fs, f, f1, fc
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
Set fc = f.Files
sc = 1
For Each f1 In fc
If Right(f1.Name, 3) = "xls" Then
fName = folderspec + f1.Name
sName = Left(f1.Name, Len(f1.Name) - 4)
Workbooks.Open fName
Sheets("Sheet1").Copy After:=Workbooks(BkName).Sheets(sc)
sc = sc + 1
Sheets(sc).Name = sName
If Workbooks(2).Name <> BkName Then
Workbooks(2).Close
End If
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "复制完毕！请保存。"
Application.FileDialog(msoFileDialogSaveAs).Show
End Sub

Answer 2

Sub dirf()
mypath = "C:\test\*.xls" '路径修改一下
myname = Dir(mypath)
Do While myname <> ""
Workbooks.Open "C:\test\" & myname
Sheets(1).Copy After:=Workbooks("test.xls").Sheets(1) 'test.xls 为试验文件，你自己的建一个，把它改成你的。
Workbooks(myname).Close
myname = Dir
Loop
End Sub