VBA Copy and paste data from unique workbooks in a user defined directory to a master workbook

Question

I'm relatively new to VBA and I am trying to create code to copy data from approximately 130 xls files in a user-specified directory and paste it into a master workbook. The workbooks and worksheets in the directory all have unique names.

The data I need to copy are in C2:J2 of each file and need to be pasted into the master sheet starting from A2:H2 and populating the next row down until the end of the files is reached.

I would like to loop through all of the files in the directory.

I have tried multiple variations of code to do this and can't seem to get it. I have been able to get the macro to open the directory and it seems to begin the process but doesn't copy and paste the data into my master worksheet. Here is the directory to my master worksheet and I've pasted the code below.

C:\Users\krist\Desktop\TestModifiedCalculated\Compiled.xlsm\

Thanks so much!!

Sub CompileData()
    Dim xRg As Range
    Dim xSelItem As Variant
    Dim xFileDlg As FileDialog
    Dim xFileName, xSheetName, xRgStr As String
    Dim xBook, xWorkBook As Workbook
    Dim xSheet As Worksheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    xSheetName = "Sheet1"
    xRgStr = "C2:J2"
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    With xFileDlg
        If .Show = -1 Then
            xSelItem = .SelectedItems.Item(1)
            Set xWorkBook = ThisWorkbook
            Set xSheet = xWorkBook.Sheets("New Sheet")
            If xSheet Is Nothing Then
                xWorkBook.Sheets.Add(After:=xWorkBook.Worksheets(xWorkBook.Worksheets.Count)).Name = "New Sheet"
                Set xSheet = xWorkBook.Sheets("New Sheet")
            End If
            xFileName = Dir(xSelItem & "\*.xls", vbNormal)
            If xFileName = "" Then Exit Sub
            Do Until xFileName = ""
               Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
                Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
                xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
                xFileName = Dir()
                xBook.Close
            Loop
        End If
    End With
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Your code works for me, try and move the on error resume next to right before set xsheet = xworkbook.sheets("New Sheet") and right after that line add in on error goto 0 to see if it errors anywhere. At a guess the sheet names aren't "Sheet1". — Warcupine
Thanks for your prompt reply! I followed your recommendation and received a dialogue box with the error message, "Runtime error 9 subscript out of range". The problem seems to be with the code: Set xSheet = xWorkBook.Sheets("New Sheet") — KristinP
Did you put the on error resume next right before that line, and right after it but on error goto 0? that should skip that line and move you into the if statement where you create it. — Warcupine
I did. After making those changes, the macro ran but no data populated. I would like the code to loop through all the files in the folder and copy data from range C2:J2 in the first sheet from each of the xls files and paste it to separate rows in the Compiled workbook. — KristinP
I'm not sure then, it works for me as long as the xls files have a sheet1 — Warcupine

Dammer15 Dammer15 · Accepted Answer · 2020-04-24T17:42:12

A slightly different approach. Hope this helps.

Sub ModSub()

Dim CopyRangeSt As String
CopyRangeSt = "C2:J2"

Dim PasteRangeSt As String
PasteRangeSt = "A2:H2"

Dim MasterWorkBook As Workbook
Set MasterWorkBook = ThisWorkbook

Dim MasterSheet As Worksheet
Set MasterSheet = MasterWorkBook.Sheets(1)


Dim SelectedPath As String
Dim counter As Long
counter = 0

'Open FileDialog to Select the Files not Directory
Dim FileDiag As FileDialog
Dim fileCount As Long

Set FileDiag = Application.FileDialog(msoFileDialogFilePicker)
    With FileDiag
        .AllowMultiSelect = True
        .Show
     End With


'Files were selected
If FileDiag.SelectedItems.Count > 0 Then

'Process Each File path. Check for .xlsx and xlsm extension to ensure you're working with Excel Files only
'Add Checked file paths to DataExcelFiles Collection. Skipping for my time here
For fileCount = 1 To FileDiag.SelectedItems.Count

'Use only Excel Files in your application
Dim dataBook As Workbook
Set dataBook = Workbooks.Open(FileDiag.SelectedItems(fileCount))

'Assuming Data is only on the first sheet
Dim dataSheet As Worksheet
Set dataSheet = dataBook.Sheets(1)

'Counter will be offsetting the row for each range of data you need pasted
MasterSheet.Range(PasteRangeSt).Offset(counter) = dataSheet.Range(CopyRangeSt).Value
counter = counter + 1

Next fileCount

End If

End Sub

VBA Copy and paste data from unique workbooks in a user defined directory to a master workbook

1 Answers