Question

我已经构建了一些代码来循环浏览文件夹中的多个文件，然后尝试将其合并为一张纸。

我最有能力做到这一点，但是只要我的源文件中只有一个订单项要复制，它就会失败。

它在代码Range(Selection, Selection.End(xlDown)).Select上失败。我用它来复制A7行中的整个行。当我有个以上一个订单项时，它就可以工作。但是当我只有一个订单项时，代码将失败。

并且还需要帮助更改目标表：我需要将其粘贴到新的工作簿中。

下面是我的代码：

Option explicit

Const FOLDER_PATH = "C:\Users\1\Desktop\New folder (4)\" 'REMEMBER END BACKSLASH


Sub ImportWorksheets()
    '=============================================
    'Process all Excel files in specified folder
    '=============================================
    Dim sFile As String 'file to process
    Dim wsTarget As Worksheet
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim rowTarget As Long 'output row

    rowTarget = 7

    'check the folder exists
    If Not FileFolderExists(FOLDER_PATH) Then
        MsgBox "Specified folder does not exist, exiting!"
        Exit Sub
    End If

    'reset application settings in event of error
    On Error GoTo errHandler
    Application.ScreenUpdating = False

    'set up the target worksheet
    Set wsTarget = Sheets("Sheet1")

    'loop through the Excel files in the folder
    sFile = Dir(FOLDER_PATH & "*.xls*")
    Do Until sFile = ""

        'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
        Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
        Set wsSource = wbSource.Worksheets(1) 'EDIT IF NECESSARY

        'import the data

        With wsTarget
            Range("A7:BI7").Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            Windows("Loop through files.xlsm").Activate
            Range("A2").Select
            Selection.End(xlDown).Select
            ActiveCell.Offset(1, 0).Select
            ActiveSheet.PasteSpecial
        End With

        'close the source workbook, increment the output row and get the next file
        Application.DisplayAlerts = False
        wbSource.Close SaveChanges:=False
        Application.DisplayAlerts = True
        rowTarget = rowTarget + 1
        sFile = Dir()
    Loop

    errHandler:
    On Error Resume Next
    Application.ScreenUpdating = True

    'tidy up
    Set wsSource = Nothing
    Set wbSource = Nothing
    Set wsTarget = Nothing
End Sub




Private Function FileFolderExists(strPath As String) As Boolean
    If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function

Answer 1

尝试一下。如果您所有的工作簿都始于A7，并且没有空的列或行，那么.CurrentRegion比尝试找出第一行，最后一行和列要好得多

Option Explicit

    Const FOLDER_PATH = "C:\Users\1\Desktop\New folder (4)\" 'REMEMBER END BACKSLASH


    Sub ImportWorksheets()
        '=============================================
        'Process all Excel files in specified folder
        '=============================================
        Dim sFile As String 'file to process
        Dim wsTarget As Worksheet
        Dim wbSource As Workbook
        Dim wsSource As Worksheet
        Dim rowTarget As Long 'output row

        rowTarget = 7

        'check the folder exists
        If Not FileFolderExists(FOLDER_PATH) Then
            MsgBox "Specified folder does not exist, exiting!"
            Exit Sub
        End If

        'reset application settings in event of error
        On Error GoTo errHandler
        Application.ScreenUpdating = True

        'set up the target worksheet
        Set wsTarget = Sheets("Sheet1")

        'loop through the Excel files in the folder
        sFile = Dir(FOLDER_PATH & "*.xls*")
        Do Until sFile = ""

            'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
            Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
            Set wsSource = wbSource.Worksheets(1) 'EDIT IF NECESSARY

            'import the data

            With wsTarget

                Range("A7").CurrentRegion.Copy
                Windows("Loop through files.xlsm").Activate
                Range("A1048576").Select
                Selection.End(xlUp).Select
                ActiveCell.Offset(1, 0).Select
                ActiveSheet.PasteSpecial
            End With

            'close the source workbook, increment the output row and get the next file
            Application.DisplayAlerts = False
            wbSource.Close SaveChanges:=False
            Application.DisplayAlerts = True
            rowTarget = rowTarget + 1
            sFile = Dir()
        Loop

    errHandler:
        On Error Resume Next
        Application.ScreenUpdating = True

        'tidy up
        Set wsSource = Nothing
        Set wbSource = Nothing
        Set wsTarget = Nothing
    End Sub




    Private Function FileFolderExists(strPath As String) As Boolean
        If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
    End Function

循环浏览文件夹中的文件

1 个答案: