谁能修改这个VBA

tanghong168

这个宏是论谈上一位高手发表的,是用于同一目录下的多个EXCEL文件的工作簿到新表的,但它会将每个文件的所有工作簿都提取出来,我只想提取每个文件的第一个工作表,请问该如何修改,我是个新手,看不明其内部含义,请哪位高手帮助一下,谢谢!

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().Move After:=ThisWorkbook.Sheets _
          (ThisWorkbook.Sheets.Count)
        x = x + 1
    Wend

ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

zhaogang1960

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).Move After:=ThisWorkbook.Sheets _
          (ThisWorkbook.Sheets.Count)
        x = x + 1
    Wend

ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub
如果要保持原文件的完整性， Sheets(1).Move After应该为：Sheets(1).Copy After

[此贴子已经被作者于2008-7-18 10:34:41编辑过]

yc2007

二楼,你好
你用的代码能合并工作簿,但能否将合并后的工作簿中的工作表名用原来的工作簿名呢?

zhaogang1960

Sub 合并工作簿()
    Dim FilesToOpen, wb As Workbook
    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)
        If FilesToOpen(x) <> ThisWorkbook.FullName Then
            Set wb = Workbooks.Open(Filename:=FilesToOpen(x))
            wb.Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            ActiveSheet.Name = Split(Split(FilesToOpen(x), "\")(UBound(Split(FilesToOpen(x), "\"))), ".")(0)
            wb.Close
        End If
        x = x + 1
    Wend

ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

yc2007

再提一个问题,就是每个工作簿中现在只有一个表的合并现在可以了.能否将多个工作簿中的多工作表合并到一个工作簿中,且在新工作簿中的工作表仍用原工作表的表名

zhaogang1960

Sub 合并工作簿()
    Dim FilesToOpen, wb As Workbook, sht As Worksheet
    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)
        If FilesToOpen(x) <> ThisWorkbook.FullName Then
            Set wb = Workbooks.Open(Filename:=FilesToOpen(x))
            For Each sht In wb.Sheets
                sht.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            Next
            wb.Close
        End If
        x = x + 1
    Wend

ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

yc2007

谢谢六楼,正是我想要的效果

liuxiao

各工作簿的第一个工作表的结构相同，可否只合并第一个工作表到汇总工作表的一张工作表中。暂不考虑合并在一起的先后顺序！代码怎么写？

zhaogang1960

原帖由 liuxiao 于 2010-3-1 15:43 发表
各工作簿的第一个工作表的结构相同，可否只合并第一个工作表到汇总工作表的一张工作表中。暂不考虑合并在一起的先后顺序！代码怎么写？

请参考：
Sub 合并工作簿()
    Dim FilesToOpen, sh As Worksheet
    Dim i&, m&

    On Error GoTo ErrHandler

    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
   
    Set sh = ActiveSheet
   
    Application.ScreenUpdating = False
    sh.UsedRange.Clear
    For i = 1 To UBound(FilesToOpen)
        If FilesToOpen(i) <> ThisWorkbook.FullName Then
            With GetObject(FilesToOpen(i))
                If .Sheets(1).UsedRange.Count > 1 Then
                     m = m + 1
                     If m = 1 Then
                        .Sheets(1).UsedRange.Copy sh.Range("a1")
                     Else
                        .Sheets(1).UsedRange.Copy sh.Range("a65536").End(xlUp).Offset(1)
                    End If
                End If
                .Close
            End With
        End If
    Next

ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

liuxiao

原帖由 zhaogang1960 于 2010-3-1 16:53 发表

请参考：
Sub 合并工作簿()
    Dim FilesToOpen, sh As Worksheet
    Dim i&, m&

    On Error GoTo ErrHandler

    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="Microsoft Exc ...

代码经测试，只是起到导入一个工作簿的工作表的作用，没有能起到汇总作用。我想实现的是汇总各工作表除表头以外的内容，连续依次按行记录！