Question

我正在尝试使用以下代码将放置在特定文件夹中的多个excel文件合并到一个工作表中。该代码是我个人宏工作簿的一部分。

    Sub Combined_Sheets()
    Dim strFolder
    strFolder = GetFolder
    Path = strFolder
    Dim NumSheets As Integer
    Dim NumRows As Double
    Dim wks As Worksheet
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    Dim number As Integer
    number = 1
    Filename = Dir(Path & "*.*")
    Do While Filename <> ""
        Workbooks.Open Filename:=Path & Filename, ReadOnly:=True, CorruptLoad:=xlRepairFile
        For Each Sheet In ActiveWorkbook.Sheets
            ActiveSheet.Name = number
            Sheet.Copy After:=wb.Sheets(1)
            number = number + 1
        Next Sheet
        Workbooks(Filename).Close savechanges:=False
        Filename = Dir()
    Loop
    Application.DisplayAlerts = False
    wb.Worksheets("Sheet1").Delete
    Application.DisplayAlerts = True
    NumSheets = ActiveWorkbook.Worksheets.Count
    Worksheets(1).Select
    Sheets.Add
    ActiveSheet.Name = "Consolidated"
    For x = 1 To NumSheets
        Worksheets(x + 1).Select
        Range("A1").Select
        Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
        Selection.Copy
        Worksheets("Consolidated").Select
        ActiveSheet.Paste
        ActiveCell.SpecialCells(xlLastCell).Offset(1, 0).Select
        Selection.End(xlToLeft).Select
        Selection.End(xlToLeft).Select
        Worksheets(x + 1).Select
        Range("A1").Select
    Next x
    Worksheets("Consolidated").Select
    Range("A1").Select
    Application.DisplayAlerts = False
    For Each wks In Worksheets
        If wks.Name <> "Consolidated" Then wks.Delete
    Next wks
    Application.DisplayAlerts = True
End Sub
Function GetFolder() As String
    Dim oFolder As Object
    GetFolder = ""
    Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
    If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
    Set oFolder = Nothing
End Function

我在运行时遇到以下错误。

运行时错误'1004'：

工作簿必须至少包含一个可见工作表。

要隐藏，删除或移动选定的工作表，首先要插入新工作表或取消隐藏已隐藏的工作表。

请在这方面提供帮助。

KAM

Answer 1

更改以下行

If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path

到

If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path & "\"

您还应该检查GetFolder是否在主代码中使用之前返回了非空字符串，可能如下：

strFolder = GetFolder
If strFolder = "" Then
    MsgBox "No directory selected - cannot continue"
    End
End If

Answer 2

您的代码确实有效，但有很多不必要的步骤。

我的getfolder功能也遇到了问题。

我只是在代码中使用这一行来选择文件夹

    With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    MyDir = .SelectedItems(1) & "\"
End With

然后，您可以遍历每张工作表并将范围复制到您的＆＃34;合并＆＃34;片。无需复制和删除工作表。

  For Each sh In Sheets

            With sh

                Set FrNg = .Range(.Range("A1"), .Range("A1").SpecialCells(xlLastCell))
                FrNg.Copy Wb.Worksheets("Consolidated").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)

            End With

        Next sh

以下是我将在您的情况下使用的完整版本。

Sub Combined_Sheets()
    Dim MyFile As String, MyDir As String, Wb As Workbook
    Dim sh As Worksheet, FrNg As Range

    Set Wb = ThisWorkbook

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        MyDir = .SelectedItems(1) & "\"
    End With

    'MyDir = "C:\TestWorkBookLoop\"
    MyFile = Dir(MyDir & "*.xls*")    'change file extension
    ChDir MyDir

    Application.ScreenUpdating = 0
    Application.DisplayAlerts = 0

    Do While MyFile <> ""
        Workbooks.Open (MyFile)

        For Each sh In Sheets

            With sh

                Set FrNg = .Range(.Range("A1"), .Range("A1").SpecialCells(xlLastCell))
                FrNg.Copy Wb.Worksheets("Consolidated").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)

            End With

        Next sh

        ActiveWorkbook.Close True
        MyFile = Dir()

    Loop

End Sub

将多个excel文件合并到一个工作表中时出现运行时错误

2 个答案: