VBA - Copying and Pasting from Multiple Excel files to Single Excel File

Question

Long time reader and admirer of StackOverflow.

Basically I am trying to to loop through a series of Excel files to copy a range of data and paste it on a single Excel workbook/sheet.

The cell range location (C3:D8, D3:E8) is not always consistent, but the table dimensions are: 29 R x 2 C. Also, the files only have 1 sheet, and aside from the table dimensions specified, no data values in other cells.

In its current form the code is executing, but not pasting anything to its destination Excel file.

I need it to

1. Find the data dimension in file (table)
2. Copy the table
3. Paste to destination (below previous table)
4. Loop through to next file
5. Repeat Step 1-4

The code is from: Excel VBA: automating copying ranges from different workbooks into one final destination sheet?

Thanks a lot for any help, I really appreciate it and please feel tell me to specify anything if my question is vague.

Sub SourcetoDest()

    Dim wbDest As Workbook
    Dim wbSource As Workbook
    Dim sDestPath As String
    Dim sSourcePath As String
    Dim shDest As Worksheet
    Dim rDest As Range
    Dim vaFiles As Variant
    Dim i As Long

    'array of folder names under sDestPath

    'array of file names under vaFiles
    vaFiles = Array("Book1.xls")

    sDestPath = "C:\Users"
    sSourcePath = "C:\Users"


    Set wbDest = Workbooks.Open(sDestPath & "\" & "Book2.xlsm")
    Set shDest = wbDest.Sheets(1)

    'loop through the files
    For i = LBound(vaFiles) To UBound(vaFiles)
        'open the source
        Set wbSource = Workbooks.Open(sSourcePath & "\" & vaFiles(i))

        'find the next cell in col C
        Set rDest = shDest.Cells(shDest.Rows.Count, 3).End(xlUp).Offset(1, 0)
        'write the values from source into destination
        rDest.Resize(5, 1).Value = wbSource.Sheets(1).Range("C7:D33").Value


        wbSource.Close False
    Next i

End Sub

Answer 1

The below should achieve what you're after.

Option Explicit
Sub copy_rng()
    Dim wb As Workbook, wbDest As Workbook, ws As Worksheet, wsDest As Worksheet, wsSrc As Worksheet
    Dim wbNames() As Variant
    Dim destFirstCell As Range
    Dim destColStart As Integer, destRowStart As Long, i As Byte
    Dim destPath As String

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Sheet1") ' Amend to your sheet name
    Set wsSrc = wb.Sheets("Sheet2") ' Amend to sheet name with table data
    wbNames = ws.Range("A2:A" & lrow(1, ws)) ' Pass col number into lrow function
    destPath = "C:\Users\"

    Application.ScreenUpdating = False
    For i = 1 To UBound(wbNames, 1)
        Set wbDest = Workbooks.Open(destPath & wbNames(i, 1))
        Set wsDest = wbDest.Worksheets(1)
        With wsDest
            Set destFirstCell = .Cells.Find(What:="*")
            destColStart = destFirstCell.Column
            destRowStart = destFirstCell.Row
            .Range(Cells(destRowStart, destColStart), _
                Cells(lrow(destColStart, wsDest), icol(destRowStart, wsDest))).Copy
        End With
        wsSrc.Cells(lrow(1, wsSrc) + 1, 1).PasteSpecial Paste:=xlPasteAll
        wbDest.Close False
    Next i
    Application.ScreenUpdating = True

End Sub

Function lrow(ByVal col_num As Integer, sheet_name As Worksheet) As Long
    lrow = sheet_name.Cells(Rows.Count, col_num).End(xlUp).Row
End Function

Function icol(ByVal row_num As Long, sheet_name As Worksheet) As Integer
    icol = sheet_name.Cells(row_num, Columns.Count).End(xlToLeft).Column
End Function

Ensure you copy both of the functions across, they're used to create the dimensions of the table, and then copying the table.

You will need to amend the sheet name variables. Let me know if you have any questions.

You need to amend the range of where the workbook names are stored. You need to pass the column number in, so that the last row can be calculated. You can also amend the column in which data is pasted back into the workbook.

Answer 2

With the help of this code you can copy all workbooks and worksheets data into one workbook

Sub copydata()

Dim fso As Scripting.FileSystemObject
Dim fill As Scripting.File
Dim oldfolder As String
Dim newfolder As String
Dim subfolder As Folder
Dim myfolder As Folder
Dim fd As FileDialog
Dim loopcount As Integer
Dim wb
Dim wb2 As Workbook
Dim rr As Range

Set fso = New Scripting.FileSystemObject

Set wb = ThisWorkbook

Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Title = "Please Select Folder to copy"
fd.ButtonName = "Go!"
fd.Show

oldfolder = fd.SelectedItems(1)

Set myfolder = fso.GetFolder(oldfolder)

'Application.ScreenUpdating = False

Application.EnableEvents = False
 

For Each subfolder In myfolder.SubFolders

    For Each fill In subfolder.Files
            If fill Like "*.xlsm" Or fill Like "*.xlsx" Or fill Like ".*xls" Then
            'fill.Range("A1:Z100").Copy
            Set wb2 = Application.Workbooks.Open(fill,0 , True)
            wb2.Activate
            For loopcount = 1 To wb2.Worksheets.Count
            wb2.Activate
            Worksheets(loopcount).Activate
            Range("A1:Z300").Copy          'Replace your range
            wb.Activate
            Sheet1.Activate
            Set rr = Range("A:A").Find("", Range("A1"))
            rr.Select
            ActiveSheet.Paste
            ActiveCell.Offset(1, 0).Select
            Next loopcount
            wb2.Close False
            End If
            
        Application.CutCopyMode = False
        
        Debug.Print fill.Name
    
    Next fill
    
Next subfolder
        MsgBox "Done"

    For Each fill In myfolder.Files
        Application.DisplayAlerts = False
    
         If fill Like "*.xlsm" Or fill Like "*.xlsx" Or fill Like ".*xls" Or fill Like "*.xlsb" Then
            'fill.Range("A1:Z100").Copy
            Set wb2 = Application.Workbooks.Open(fill, 0, True)
            wb2.Activate
            
            For loopcount = 1 To wb2.Worksheets.Count
        
            wb2.Activate
            Worksheets(loopcount).Activate
            
            Range("A:Z").EntireColumn.Hidden = False
            
            Range("A1:Z1").AutoFilter
            Range("A1:Z300").Copy
            wb.Activate
            
            Sheet1.Activate
            Set rr = Range("A:A").Find("", Range("A1"))
            rr.Select
            ActiveSheet.Paste
            ActiveCell.Offset(1, 0).Select
            Next loopcount
            wb2.Close False
            End If
            
        Application.CutCopyMode = False
        
        Debug.Print fill.Name
        
    Next fill

Application.EnableEvents = True

End Sub