vba合并一个目录下的指定文件名的多个excel文件为一个excel

[逗号xzlhs]

我有一个需求：就是用vba实现把一个目录下（D:\test）（包括子目录下）文件名为test开头的excel文件（如：test20140404.xlsx）全部复制到一个新目录下（如：E:\test），并把这些excel文件内容合并到一个新的excel文件里！
求高手写出代码赐教

[逗号xzlhs]

引用 2 楼 xbj_hyml 的回复:

Option Explicit

Sub union()
    Dim fso As FileSystemObject, tFolder As Folder, tFile As File
    Dim fName As String
    
'    On Error GoTo hErr
    Set fso = New FileSystemObject
    Set tFolder = fso.GetFolder(ThisWorkbook.Path)  ' 文件夹路径
    Application.ScreenUpdating = False
    For Each tFile In tFolder.Files
        fName = tFile.Name
        If Right(fName, 5) = ".xlsx" Then       '判断条件
            If InStr(fName, "test") > 0 Then    '判断条件
                Call CopySheets(tFile.Path, fName)  '拷贝工作表
            End If
        End If
    Next
    Application.ScreenUpdating = True
    Set tFile = Nothing
    Set tFolder = Nothing
    Set fso = Nothing
    Exit Sub
'hErr:
'    Set tFile = Nothing
'    Set tFolder = Nothing
'    Set fso = Nothing
'    MsgBox "error in union()"
End Sub

Sub CopySheets(ByVal fPath As String, ByVal fName As String)
    Dim tWB As Workbook, tWS As Worksheet
'    On Error GoTo hErr
    Application.ScreenUpdating = False
    Set tWB = Workbooks.Open(fPath, True, True)
    '循环拷贝工作表，并重命名
    For Each tWS In tWB.Worksheets
        tWS.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
        ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count).Name = Mid(fName, 1, InStr(fName, ".")) & "_" & tWS.Name
    Next
    tWB.Close
    Application.ScreenUpdating = True
    Set tWS = Nothing
    Set tWB = Nothing
    Exit Sub
'hErr:
'    Set tWS = Nothing
'    Set tWB = Nothing
'    MsgBox "error in copysheets()"
End Sub

'--这是宏代码部分(union),功能差不多OK，具体的可能还需要调整
'--文件夹目录：test1.xlsx,test2.xlsx,union.xlsm

我用你的代码测试的时候报用户定义类型未定义
是不是缺少什么引用啊

[逗号xzlhs]

引用 3 楼 xbj_hyml 的回复:

还有个问题是，拷贝的时候，由于中间打开并关闭 被拷贝的工作簿，任务栏会出现闪烁， 我还没研究出怎么避免这个，希望大牛指教... 有什么问题，希望大家一起讨论下..

还有我想问下你，执行完之后合并的excel是在什么目录下？看你的代码都没有指定目录的

[赵4老师]

可以设置Excel不显示。

[逗号xzlhs]

怎么没人回答

[xbj_hyml]

Option Explicit

Sub union()
    Dim fso As FileSystemObject, tFolder As Folder, tFile As File
    Dim fName As String
    
'    On Error GoTo hErr
    Set fso = New FileSystemObject
    Set tFolder = fso.GetFolder(ThisWorkbook.Path)  ' 文件夹路径
    Application.ScreenUpdating = False
    For Each tFile In tFolder.Files
        fName = tFile.Name
        If Right(fName, 5) = ".xlsx" Then       '判断条件
            If InStr(fName, "test") > 0 Then    '判断条件
                Call CopySheets(tFile.Path, fName)  '拷贝工作表
            End If
        End If
    Next
    Application.ScreenUpdating = True
    Set tFile = Nothing
    Set tFolder = Nothing
    Set fso = Nothing
    Exit Sub
'hErr:
'    Set tFile = Nothing
'    Set tFolder = Nothing
'    Set fso = Nothing
'    MsgBox "error in union()"
End Sub

Sub CopySheets(ByVal fPath As String, ByVal fName As String)
    Dim tWB As Workbook, tWS As Worksheet
'    On Error GoTo hErr
    Application.ScreenUpdating = False
    Set tWB = Workbooks.Open(fPath, True, True)
    '循环拷贝工作表，并重命名
    For Each tWS In tWB.Worksheets
        tWS.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
        ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count).Name = Mid(fName, 1, InStr(fName, ".")) & "_" & tWS.Name
    Next
    tWB.Close
    Application.ScreenUpdating = True
    Set tWS = Nothing
    Set tWB = Nothing
    Exit Sub
'hErr:
'    Set tWS = Nothing
'    Set tWB = Nothing
'    MsgBox "error in copysheets()"
End Sub

'--这是宏代码部分(union),功能差不多OK，具体的可能还需要调整
'--文件夹目录：test1.xlsx,test2.xlsx,union.xlsm

[xbj_hyml]

还有个问题是，拷贝的时候，由于中间打开并关闭 被拷贝的工作簿，任务栏会出现闪烁， 我还没研究出怎么避免这个，希望大牛指教... 有什么问题，希望大家一起讨论下..

[xbj_hyml]

1、错误是要引用 Microsoft Scripting Runtime 库 2、合并后，就是当前打开的Excel 啊，如果你要另存，就在Uion()中for...next后面加一个 ThisWorkbook.SaveAs “路径"

[xbj_hyml]

引用 6 楼 zhao4zhong1 的回复:

可以设置Excel不显示。

我研究研究..

[赵4老师]

引用 8 楼 xbj_hyml 的回复:

[quote=引用 6 楼 zhao4zhong1 的回复:] 可以设置Excel不显示。

我研究研究..[/quote]

Application.Visible=False

[xbj_hyml]

引用 9 楼 zhao4zhong1 的回复:

[quote=引用 8 楼 xbj_hyml 的回复:] [quote=引用 6 楼 zhao4zhong1 的回复:] 可以设置Excel不显示。

我研究研究..[/quote]

Application.Visible=False

[/quote] 谢谢，赵大牛..