[已解决]合并文件夹里面很多工作薄到一个工作薄中

wml514166604

我想把一个文件夹里面的很多工作薄合并到一个工作薄里面来，比如：第一个工作薄里面有3张表格，第二个工作薄里面有3张，。。。一直到第10个工作薄里面有3个，那么合并到一个工作薄里面来就有30张工作表。望高手解决 谢谢

最佳答案

月排行榜 / 总排行榜

Kratos

2011-4-12 11:43

这不就是和哥一样的问题嘛，吼吼
Sub ImportData()
    Dim MyObject As Object
    Dim strPath As String, strFileName As String, strMyName As String
    Dim shtSheet As Worksheet, strShtName As String
    Dim intCount As Integer, intShtCount As Integer, i As Integer
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    strPath = ThisWorkbook.Path
    strMyName = ThisWorkbook.Name
    intShtCount = ThisWorkbook.Sheets.Count
    With Application.FileSearch
        .NewSearch
        .LookIn = strPath
        .SearchSubFolders = False
        .Filename = ".xls"
        .FileType = msoFileTypeOfficeFiles
        If .Execute() > 0 Then
            intCount = .FoundFiles.Count
            For i = 1 To intCount
                strFileName = Replace(.FoundFiles(i), strPath & "\", "")
                If strFileName <> strMyName Then
                    Set MyObject = GetObject(strPath & "/" & strFileName)
                    For Each shtSheet In MyObject.Worksheets
                        strShtName = shtSheet.Name
                        If MyObject.Sheets(strShtName).UsedRange.Count > 1 Then
                            MyObject.Sheets(strShtName).Copy After:=ThisWorkbook.Sheets(intShtCount)
                        End If
                    Next shtSheet
                    MyObject.Close
                End If
            Next i
        Else
            MsgBox "Invalid option!", vbCritical, "Wrong data"
    End If
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Data Imported", vbInformation, "Confirmation"
End Sub

跳转到最佳答案楼层

兰色幻想

是合并，还是汇总数据？

Kratos

这不就是和哥一样的问题嘛，吼吼
Sub ImportData()
    Dim MyObject As Object
    Dim strPath As String, strFileName As String, strMyName As String
    Dim shtSheet As Worksheet, strShtName As String
    Dim intCount As Integer, intShtCount As Integer, i As Integer
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    strPath = ThisWorkbook.Path
    strMyName = ThisWorkbook.Name
    intShtCount = ThisWorkbook.Sheets.Count
    With Application.FileSearch
        .NewSearch
        .LookIn = strPath
        .SearchSubFolders = False
        .Filename = ".xls"
        .FileType = msoFileTypeOfficeFiles
        If .Execute() > 0 Then
            intCount = .FoundFiles.Count
            For i = 1 To intCount
                strFileName = Replace(.FoundFiles(i), strPath & "\", "")
                If strFileName <> strMyName Then
                    Set MyObject = GetObject(strPath & "/" & strFileName)
                    For Each shtSheet In MyObject.Worksheets
                        strShtName = shtSheet.Name
                        If MyObject.Sheets(strShtName).UsedRange.Count > 1 Then
                            MyObject.Sheets(strShtName).Copy After:=ThisWorkbook.Sheets(intShtCount)
                        End If
                    Next shtSheet
                    MyObject.Close
                End If
            Next i
        Else
            MsgBox "Invalid option!", vbCritical, "Wrong data"
    End If
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Data Imported", vbInformation, "Confirmation"
End Sub

map123

Kratos 发表于 2011-4-12 11:43
这不就是和哥一样的问题嘛，吼吼
Sub ImportData()
    Dim MyObject As Object

楼主好像不能运行， With Application.FileSearch
提示错误

砖石矿工

对象不支持该动作