Скопируйте ячейки из нескольких файлов Excel и вставьте их в основной файл

Question

Я получил этот код VBA, который должен считывать ячейки из закрытых файлов Excel (которые находятся в одной папке) и копировать содержимое в основной файл. Кажется, что файлы считываются так, как предполагается, однако вставка скопированного контекста, похоже, не работает.

Есть идеи?

Sub ReadAndMerceData()

Dim objFs As Object
Dim objFolder As Object
Dim file As Object

Set objFs = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFs.GetFolder("C:\Users\XXX\Desktop\TEST")

Dim iStartRow As Integer
iStartRow = 0

For Each file In objFolder.Files

    Dim src As Workbook
    Set src = Workbooks.Open(file.Path)

    Dim iTotalRows As Integer
    iTotalRows = 50

    Dim iTotalCols As Integer
    iTotalCols = 17
    Dim iRows, iCols As Integer

    For iRows = 1 To iTotalRows
        For iCols = 1 To iTotalCols
            Cells(iRows + iStartRow, iCols) = src.Worksheets("Tabelle1").Cells(iRows, iCols)
        Next iCols
    Next iRows

    iStartRow = iRows + 1
    iRows = 0

    src.Close False
    Set src = Nothing
Next

End Sub

Answer 1

Вам не нужно копировать ячейку за ячейкой. Вы можете скопировать весь диапазон одновременно, что намного быстрее.

Также убедитесь, что вы указали рабочую книгу и рабочую таблицу, в которую хотите скопировать. Никогда не используйте Range или Cells без указания рабочего листа (или Excel угадает, и это может быть неправильно).

Option Explicit

Public Sub ReadAndMerceData()
    Dim objFs As Object        
    Set objFs = CreateObject("Scripting.FileSystemObject")

    Dim objFolder As Object
    Set objFolder = objFs.GetFolder("C:\Users\XXX\Desktop\TEST")

    Dim dest As Worksheet 'define your destination sheet!
    Set dest = ThisWorkbook.Worksheets("DestinationSheet")

    'make them variabes if they are dynamic otherwise use constants if hardcoded.
    Const TotalRows As Long = 50
    Const TotalCols As Long = 17 

    Dim iStartRow As Long

    Dim file As Object
    For Each file In objFolder.Files
        Dim src As Workbook
        Set src = Workbooks.Open(file.Path)

        'copy all cells at once
        dest.Cells(iStartRow + 1, 1).Resize(TotalRows, TotalCols).Value = src.Worksheets("Tabelle1").Cells(1, 1).Resize(TotalRows, TotalCols).Value

        iStartRow = iStartRow + TotalRows + 1

        src.Close SaveChanges:=False
    Next file
End Sub

Объяснение

Эта dest.Cells(iStartRow + 1, 1) является первой ячейкой, которую мы Если вы хотите скопировать в него с помощью .Resize(TotalRows, TotalCols), мы расширяем эту ячейку в диапазон и устанавливаем ее .Value равной диапазону исходных листов, который начинается в первой ячейке src.Worksheets("Tabelle1").Cells(1, 1) и имеет такое же количество строк и столбцов .Resize(TotalRows, TotalCols).

Обратите внимание, что копирование полного диапазона всегда выполняется быстрее, чем копирование одной и той же ячейки данных за ячейкой, поскольку необходимо выполнить только одно действие копирования.

Answer 2

Foloowing @BigBen, а также предложения @ Pᴇʜ, а также упорядочение кода для повышения его эффективности, попробуйте изменить приведенный ниже код:

Option Explicit

Sub ReadAndMerceData()

' Objects and parameters declaration section
Dim objFs As Object
Dim objFolder As Object
Dim file As Object
Dim src As Workbook
Dim wb As Workbook
Dim ws As Worksheet
Dim iStartRow As Long, iTotalRows As Long, iTotalCols As Long, iRows As Long, iCols As Long

Set objFs = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFs.GetFolder("C:\Users\XXX\Desktop\TEST")

' remove screen flickering (speed your code's run-time)
Application.ScreenUpdating = False

' set the result worknook and worksheet objects (modify to suit your needs)
Set wb = ThisWorkbook
Set ws = wb.Worksheets("sheet1") ' <-- modify "Sheet1" to your sheet's name

' set your parameters once, don't need to set them every time inside the loop
iStartRow = 0
iTotalRows = 50
iTotalCols = 17
For Each file In objFolder.Files
    Set src = Workbooks.Open(file.Path)

    For iRows = 1 To iTotalRows
        For iCols = 1 To iTotalCols
            ws.Cells(iRows + iStartRow, iCols) = src.Worksheets("Tabelle1").Cells(iRows, iCols)
        Next iCols
    Next iRows

    iStartRow = iRows + 1
    iRows = 0

    src.Close False
    Set src = Nothing
Next

Application.ScreenUpdating = True

End Sub