多个工作簿合并到一个工作簿

老虎爱吃包子

各位大神，现有一段代码，是将多个工作簿的第一个sheet表合并到汇总工作簿中，汇总工作簿中的sheet表名称是多个源工作簿shee1的名称。问题来了，怎样修改代码，将生成合并后的工作簿中的sheet表以源工作簿的名称命名。代码如下，请各位大神帮忙修改。

Private Sub 合并工作薄()
    Dim f_name As String
    Dim bok1 As Workbook, bok2 As Workbook
    Set bok2 = Nothing
    f_name = Dir("C:\Documents and Settings\桌面\例样\*.*")
    Do While f_name <> ""
        Set bok1 = Workbooks.Open(f_name)
        If bok2 Is Nothing Then
            bok1.Sheets(1).Copy
            Set bok2 = ActiveWorkbook
        Else
            bok1.Sheets(1).Copy Before:=bok2.Sheets(1)
        End If
        bok1.Close
        f_name = Dir()
    Loop
End Sub

lhdcxz

bok2.Sheets(1).name=bok1.name

老虎爱吃包子

lhdcxz 发表于 2012-3-8 10:24
bok2.Sheets(1).name=bok1.name

Indcxz，可否帮忙添加到原代码中去，拜谢。

lhdcxz

Else
             bok1.Sheets(1).Copy Before:=bok2.Sheets(1)
             bok2.Sheets(1).name=bok1.name
End If

老虎爱吃包子

lhdcxz 发表于 2012-3-8 10:56
Else
             bok1.Sheets(1).Copy Before:=bok2.Sheets(1)
             bok2.Sheets(1).name=bok1 ...

谢谢大神，我测试运行了一下，只把汇总表的第一个sheet表名称改了，后面的没改动。（有三个源工作簿，在汇总表生成三个sheet表，现在只把汇总表的第一个sheet表名称改为源工作簿的名称了，其余两个依然是源工作簿引用合并的sheet表的名称），还需要怎样修改？请不吝赐教。

jiminyanyan

最好上个附件。。。。

lhdcxz

Private Sub CommandButton1_Click() '合并工作薄()
     Dim f_name As String
     Dim bok1 As Workbook, bok2 As Workbook
     Set bok2 = Nothing '设置为空
     f_name = Dir(ThisWorkbook.Path & "\" & "*.xls") '获得本文件夹下的工作簿名称
     Do While f_name <> "" And f_name <> ThisWorkbook.Name '不是空并且不是自己
         Set bok1 = Workbooks.Open(ThisWorkbook.Path & "\" & f_name) '打开它
         If bok2 Is Nothing Then 'bok2不是空就
             bok1.Sheets(1).Copy '拷贝打开的文件
             Set bok2 = ActiveWorkbook '激活bok2
             bok2.Sheets(1).Name = bok1.Name '用打开的文件名命名
         Else
             bok1.Sheets(1).Copy Before:=bok2.Sheets(1) '拷贝打开的文件到新工作表
             bok2.Sheets(1).Name = bok1.Name ''用打开的文件名命名
         End If
         bok1.Close '关闭打开的文件
         f_name = Dir() ''获得本文件夹下的工作簿名称
     Loop '循环

End Sub

老虎爱吃包子

lhdcxz 发表于 2012-3-8 11:35
Private Sub CommandButton1_Click() '合并工作薄()
     Dim f_name As String
     Dim bok1 As Workbo ...

已测试，很好用，万分感谢！

jzfljcq

lhdcxz 发表于 2012-3-8 11:35
Private Sub CommandButton1_Click() '合并工作薄()
     Dim f_name As String
     Dim bok1 As Workbo ...

bok1.Sheets(1).Copy Before:=bok2.Sheets(1) '拷贝打开的文件到新工作表
运行这句时有错误提示　错误1004，excel无法将工作表插入工作簿中，因为目标工作簿的行数、列数比源的行数、列数少，请问应该如何处理？
注：我在2003环境下运行就没有这个提示。这是怎么回事？？

lhdcxz

也许应该改这句
f_name = Dir(ThisWorkbook.Path & "\" & "*.xls") '获得本文件夹下的工作簿名称
里面的"*.xls" 后缀名为高版本的后缀名。