Перебрать файлы в папке

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