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

honglei_yu

之前找到的代码 只能复制工作簿的第一个sheet,怎么改成所有SHEET
第二个问题是如果文件夹里的文件也可以识别那就太好了
老师们辛苦啦 还望指教  非常感谢

将要合并的文件copy到一个新文件夹（只有这些Excel，且若打开某一文件，数据就能看见——即不用点其他sheet），建一新Excel，也存到该文件夹。仅打开该新Excel，按Alt+F11，点菜单的插入，模块，粘贴如下代码：
Sub Find()
Application.ScreenUpdating = False
Dim MyDir As String
MyDir = ThisWorkbook.Path & "\"
ChDrive Left(MyDir, 1) 'find all the excel files
ChDir MyDir
Match = Dir$("")
Do
If Not LCase(Match) = LCase(ThisWorkbook.Name) Then
Workbooks.Open Match, 0 'open
ActiveSheet.Copy Before:=ThisWorkbook.Sheets(1) 'copy sheet
Windows(Match).Activate
ActiveWindow.Close
End If
Match = Dir$
Loop Until Len(Match) = 0
Application.ScreenUpdating = True
End Sub
在此界面之间按F5运行此宏，所有表格复制到一个Excel里了。
注意：本操作只合并EXCEL中打开时看到的SHEET。即想要合并哪个sheet,就要在哪个sheet打开时点保存。

闻启学

下面代码  

无测试，都是网上资源


Sub CombineWorkbooks()
    Dim strFileName As String
    Dim wb As Workbook
    Dim ws As Object

    '包含工作簿的文件夹,可根据实际修改
    Const strFileDir As String = "D:示例数据记录"

    Application.ScreenUpdating = False

    Set wb = Workbooks.Add(xlWorksheet)
    strFileName = Dir(strFileDir & "*.xls*")

    Do While strFileName <> vbNullString
        Dim wbOrig As Workbook
        Set wbOrig = Workbooks.Open(Filename:=strFileDir & strFileName, ReadOnly:=True)
        strFileName = Left(strFileName, 2)

        For Each ws In wbOrig.Sheets
            ws.Copy After:=wb.Sheets(wb.Sheets.Count)

            wb.Sheets(wb.Sheets.Count).Name = strFileName & ws.Index

        Next

        wbOrig.Close SaveChanges:=False

        strFileName = Dir

    Loop

    Application.DisplayAlerts = False
    wb.Sheets(1).Delete
    Application.DisplayAlerts = True

    Application.ScreenUpdating = True

    Set wb = Nothing

End Sub

ykcbf1100

楼主还是上传一个附件吧。