從多個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) 。

請注意，復制完整范圍始終比逐個單元格復制相同數據要快，因為只需執行 1 個復制操作。

Answer 2

遵循@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