谁能修改这个VBA

tanghong168 · 发表于 2008-7-18 10:10

这个宏是论谈上一位高手发表的,是用于同一目录下的多个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 · 发表于 2008-7-18 10:29

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 · 发表于 2009-6-17 09:11

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

zhaogang1960 · 发表于 2009-6-17 11:03

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 · 发表于 2009-6-17 11:11

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

zhaogang1960 · 发表于 2009-6-17 17:07

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 · 发表于 2009-6-17 17:29

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

liuxiao · 发表于 2010-3-1 15:43

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

zhaogang1960 · 发表于 2010-3-1 16:53

原帖由 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 · 发表于 2010-3-1 21:29

原帖由 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 ...

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

		自动登录	找回密码
密码			免费注册

谁能修改这个VBA

回复：（tanghong168）谁能修改这个VBA

回复 3楼 yc2007 的帖子

回复 5楼 yc2007 的帖子