工作簿合并问题-已解决

fanny_neyney

问题如下：

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

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

[此贴子已经被作者于2008-9-1 16:28:56编辑过]

LangQueS

http://club.excelhome.net/viewthread.php?tid=338972

fanny_neyney

谢谢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

LangQueS

建议给参考帖代码作者发个论坛短信求助。

fanny_neyney

这里高手很多的~~~

gvntw

用你的代码修改一下：

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

fanny_neyney

瞧，高手如云吧，嘿嘿，谢谢哦，大家帮了我好多忙了

lyllc2002

能够将路径默认为当前工作簿的相同的文件夹吗？如果能这样，将操作变为更便捷。

[此贴子已经被作者于2008-9-2 15:07:43编辑过]

wskcel

好

ZXF561111

如果我只要 值和数字格式 代码该如何添加