CODEWITHSUNDEEP
excelvba
Vincenzo
Vincenzo

Reputation: 321

Copy cells from multiple excel files and paste them into master file

I got this VBA Code which is supposed to read out the cells from closed excel files (which are located in one folder) and copy the content into the master file. It seems to read out the files as supposed however pasting the copied contend seems not to work.

Any ideas?

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

Upvotes: 2

Views: 529

Answers (2)

Pᴇʜ
Pᴇʜ

Reputation: 57683

You don't need to copy over cell by cell. You can copy over the whole range at once, which is a lot faster.

Also make sure you specify the workbook and worksheet you want to copy into. Never use Range or Cells without specifing the worksheet (or Excel will guess and it might be wrong).

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

Explanation

This dest.Cells(iStartRow + 1, 1) is the first cell we want to copy into so with .Resize(TotalRows, TotalCols) we expand that cell into a range and set its .Value equal to the source sheets range which starts in the first cell src.Worksheets("Tabelle1").Cells(1, 1) and has the same amount of rows and coluns .Resize(TotalRows, TotalCols).

Note that copying a full range is always faster than copying the same data cell by cell, because it is only 1 copy action that has to be performed.

Upvotes: 3

Shai Rado
Shai Rado

Reputation: 33672

Foloowing @BigBen and also @Pᴇʜ suggestions, and also ordering your code a little to be more efficient, try the modified code below:

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

Upvotes: 2

Related Questions