工作簿合并问题-已解决

问题如下：

以2008-08为名的文件夹内有31个工作簿，取名分别为“每日通话记录8月1日”到“每日通话记录8月31日”，想要把此文件夹内的所有工作簿内的Sheet1分别复制到一个工作簿内，而这个新的工作簿内有名字分别为“8-1”到“8-31”的31个工作表。

麻烦各位高手赐教宏代码，不胜感激！

谢谢LangQueS，不过有个问题，运行完以后原来的工作簿都是打开状态，没有自动关闭，另外，是否有办法让复制后的工作表的名字和原来工作簿的名字相同呢？谢谢

Sub 合并工作簿()
    Dim FilesToOpen
    Dim x As Integer

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="Microsoft Excel Files (*.xls), *.xls", _
      MultiSelect:=True, Title:="Files to Merge")

    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "No Files were selected"
        GoTo ExitHandler
    End If

    x = 1
    While x <= UBound(FilesToOpen)
        Workbooks.Open Filename:=FilesToOpen(x)
        Sheets(1).Copy After:=ThisWorkbook.Sheets _
          (ThisWorkbook.Sheets.Count)
        x = x + 1
    Wend

ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

用你的代码修改一下：

Sub 合并工作簿()
    Dim FilesToOpen
    Dim x As Integer

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="Microsoft Excel Files (*.xls), *.xls", _
      MultiSelect:=True, Title:="Files to Merge")

    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "No Files were selected"
        GoTo ExitHandler
    End If

    x = 1
    While x <= UBound(FilesToOpen)
        Set wb = Workbooks.Open(Filename:=FilesToOpen(x))
        With wb
            .Sheets(1).Copy after:=ThisWorkbook.Sheets _
                (ThisWorkbook.Sheets.Count)
            ActiveSheet.Name = Replace(wb.Name, ".xls", "")  '工作表命名
            .Close False  '不保存关闭工作簿
        End With
        x = x + 1
    Wend

ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

好