目的：将多个excel文件中的工作簿(map)提取出并全部集中到一个新文件中。

详细解释：例如一个目录下有01.xlsx~25.xlsx文件，每个xlsx文件中都有一个名为“map”的sheet（且每个xlsx文件中都只有一个sheet）。现在我想把每个文件中的名为“map”的sheet提取出来，合并到一个新的文件“1.xlsx”中。并且每提取一个名为“map”的sheet写入新文件后将该sheet名“map”改成“1”~“25”（序号）。

例如，
提取了01.xlsx文件中的“map”工作簿后，写入1.xlsx，将sheet“map”改成“1”；
提取了02.xlsx文件中的“map”工作簿后，写入1.xlsx，将sheet“map”改成“2”；
提取了03.xlsx文件中的“map”工作簿后，写入1.xlsx，将sheet“map”改成“3”；
。
。
。
提取了25.xlsx文件中的“map”工作簿后，写入1.xlsx，将sheet“map”改成“25”；

全部文件提取写入完后，打开1.xlsx查看，内部应该有25个sheet，名字分别是“1”~“25”（按文件读取写入的顺序排列）。


目前问题：全部文件提取写入完后，打开1.xlsx查看，内部只有两个sheet，一个是“map”，一个是“25”，查看“map”sheet内容，是25.xlsx内容。也就是说，在读取新的excel文件后，写入并不是向后添加，而是不断的覆盖，所有文件提取写入完后，新文件中只保留了最后一个文件内容，并且这个“map”sheet我不需要，只要序号sheet就行了。

程序源码：

Private Sub Command1_Click()
Dim S() As String, i As Integer, j As Integer
Dim xlApp
Dim xlBook
Dim xlSheet
For i = 0 To File1.ListCount - 1
Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象
xlApp.DisplayAlerts = False '不显示对话框
Set xlBook = xlApp.Workbooks.Open(Dir1.Path & "\" & File1.List(i)) '打开已经存在的EXCEL工件簿文件
xlApp.Visible = False '设置EXCEL对象可见（或不可见）
Set xlSheet = xlBook.Worksheets("map") '设置活动工作表
xlSheet.Cells.Select
   xlSheet.Cells.Copy
    'xlApp.Workbooks.Add
    xlBook.Worksheets.Add(after:=xlBook.Worksheets("map")).Name = (i + 1)
    xlApp.ActiveSheet.Paste
    xlApp.Application.CutCopyMode = False
    xlApp.ActiveWorkbook.SaveAs FileName:="c:\1.xlsx" '保存工作表,
xlBook.Close (True) '关闭工作簿 这里的True表示退出时保存修改
xlApp.Quit '结束EXCEL对象
Set xlApp = Nothing '释放xlApp对象
Next i
MsgBox "ok"
End Sub
Private Sub Dir1_Change()
    File1.Path = Dir1.Path
'File1.Refresh
End Sub
Private Sub Drive1_Change()
    Dir1.Path = Drive1.Drive
End Sub

Private Sub Form_Load()
File1.Pattern = "*.xlsx"
End Sub

附件为用于做实验用的25个excel文件。


求版主和大神们帮助帮助我。告诉我程序中哪里错了和如何修改，多谢多谢！！

求版主和路过的大神们帮助帮助我。告诉我程序中哪里错了和如何修改，多谢多谢！

你这个代码就是只能实现“Map” +“25”的效果
因为你每次都只是打开一个 0X.xlsx，将“Map”复制之后修改为“X”。 最后保存为1.xlsx，每次都是将上次的结果覆盖掉。
所以你只有两个sheet“Map”、“X”。 循环25次当然就是“Map” +“25”
你需要做的是将“Map”从0X.xlsx复制到1.xlsx
下面是VBA的宏的代码自己研究修改一下

Workbooks("01.xlsx").Sheets("Map").Copy Before:=Workbooks("1.xlsx").Sheets(1)
Sheets("Map").Name = "01"

真对不起，VBA 实在不会，您的这两句我能读懂，但由于因为它们之间的一些写法上的差异，感到无所适从，思考和尝试了一下午，还是不会修改成VB语言应用到我的代码中，真是不好意思。



恳求您的帮助  。

不就是一样的么，区别就是VB需要创建对象，VBA可以直接使用而已
VBA

Workbooks("01.xlsx").Sheets("Map").Copy Before:=Workbooks("1.xlsx").Sheets(1)
Sheets("Map").Name = "01"

VB

Set xlBook = xlApp.Workbooks.Open(Dir1.Path & "\01.xlsx")
Set xlBook2 = xlApp.Workbooks.Open("C:\01.xlsx")
xlBook.Sheets("Map").Copy Before:=xlBook2.Sheets(1)
xlBook2.Sheets("Map").Name = "01"

感谢xiangyue0510版主，在你的帮助下，终于可以将多个EXCEL文件中的"map"sheet提取集中到一个新文件中了。
但现在又出现了一个新问题：
在新文件中，Sheet的排列方式有问题，现在生成的排列方式为：
25、24、23、22......3、2、1
这是怎么回事呢？

请xiangyue0510版主以及其他路过的版主和朋友们帮看看我的代码中哪里有问题，并请告知如何修改，谢谢！！
另，测试用的EXCEL文件在一楼。 谢谢各位了！

    Dim xlApp As Object ' Excel.Application
    Dim xlBook As Object ' Excel.Workbook
    Dim xlsheet As Object 'Excel.Worksheet
    Dim newApp As New Excel.Application
    Dim newBook1 As New Excel.Workbook
    Dim newBook2 As New Excel.Workbook

Private Sub Command1_Click()
If Dir("c:\temp.xlsx") = "" Then
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Add
    xlApp.Visible = False
    Set xlsheet = xlBook.Worksheets(3)
    xlApp.ScreenUpdating = False  '屏幕更新关

xlBook.SaveAs "c:\temp.xlsx"
'在退出窗体前，释放excel相应变量

xlBook.Close
Set xlsheet = Nothing
Set xlBook = Nothing
xlApp.Quit
Set xlApp = Nothing  '注意：xlApp要先Quit，后Nothing
End If

    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Add

    xlApp.DisplayAlerts = False '不显示对话框
    Set newBook2 = xlApp.Workbooks.Open("c:\temp.xlsx")

    For i = 0 To File1.ListCount - 1
    
    Set newBook1 = xlApp.Workbooks.Open(Dir1.Path & "\" & File1.List(i))
    
    newBook1.Sheets("Map").Copy after:=newBook2.Sheets(Sheets.Count)
    newBook2.Sheets("Map").Name = i + 1
    
    newApp.Visible = False
    Next i
    
' newBook2.SaveAs "c:\导出.xlsx"
 newBook2.Worksheets("Sheet3").Delete

 newBook2.Worksheets("Sheet2").Delete

 newBook2.Worksheets("Sheet1").Delete

 newBook2.SaveAs "c:\temp.xlsx"
    
    Set newBook1 = Nothing
    Set newBook2 = Nothing
    Set newApp = Nothing

MsgBox "ok"
End Sub

Private Sub Dir1_Change()
    File1.Path = Dir1.Path
'File1.Refresh
End Sub
Private Sub Drive1_Change()
    Dir1.Path = Drive1.Drive
End Sub

Private Sub Form_Load()
File1.Pattern = "*.xlsx"
End Sub

    newBook1.Sheets("Map").Copy after:=newBook2.Sheets(Sheets.Count)

两种添加方式，看来你需要根据你的要求选择
after    之后
Before   之前

1、对原文件名进行排序，从小的开始复制起，每次都使用 之后。

2、每次复制时，查找 表的名字，然后 对应插入到位置中去。

VBA里面自己研究一下么，无非就是after和before，还有就是指定插入之前或者之后的sheet的名称

嗯嗯，谢谢两位版主的指教，我把  newBook1.Sheets("Map").Copy after:=newBook2.Sheets(Sheets.Count)做了修改，
改成  newBook1.Sheets("Map").Copy after:=newBook2.Sheets(newBook2.Sheets.Count) ，这样就对了。

所以说，“一语惊醒梦中人”这句话还是对的，自己往往会迷失在自己的思路中，高人的一句指点，就会直击要害，令人醍醐灌顶，恍然大悟，谢谢两位的指导！