Pull data from multiple files with multiple unknown sheet names in each

cjouban

New Member
Joined
Jan 21, 2014
Messages
23
Sorry if I missed a thread that solves this. I am trying to copy same cell in multiple workbooks with multiple sheets to a new workbook. I've found examples that require a sheet name but I have know idea what each sheet is named. The macro needs to work it's way through all files in a folder and each sheet in the file pasting the results in a new workbook. Thanks in advance for any help.
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
What is the cell you want to copy? Where in the destination sheet do you want to paste the cells values? What is the full path to the folder containing the files? What is the extension of the files (xlsx, xlsm)?
 
Upvote 0
There are multiple cells I want to copy. For this let's say A1, A3, B2 & B4.
The destination sheet is the active workbook where I run the macro. Paste each copied cell in the next blank row.
The path will change. I was going to update it each time.
The files are xlsx

Thank you
 
Upvote 0
Place this macro in the active workbook and rename one sheet as "Summary". When you run the macro you will be prompted to select the folder containing your files.
Code:
Sub CopyData()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWB As Workbook, ws As Worksheet
    Set desWS = ThisWorkbook.Sheets("Summary")
    Dim FolderName As String
    With Application.FileDialog(msoFileDialogFolderPicker)
       .AllowMultiSelect = False
       .Show
       FolderName = .SelectedItems(1) & "\"
    End With
    ChDir FolderName
    strExtension = Dir("*.xlsx")
    Do While strExtension <> ""
        Set srcWB = Workbooks.Open(FolderName & strExtension)
        For Each ws In Sheets
            With ws
                desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0) = .Range("A1")
                desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0) = .Range("A3")
                desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0) = .Range("B2")
                desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0) = .Range("B4")
            End With
        Next ws
        srcWB.Close False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
I changed the desWS name and and destination range to run a test. The srcWB opens but nothing is copied to desWS. It doesn't produce any errors.

VBA Code:
Sub CopyData()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWB As Workbook, ws As Worksheet
    Set desWS = ThisWorkbook.Sheets("Sheet1")
    Dim FolderName As String
    With Application.FileDialog(msoFileDialogFolderPicker)
       .AllowMultiSelect = False
       .Show
       FolderName = .SelectedItems(1) & "\"
    End With
    ChDir FolderName
    strExtension = Dir("*.xlsx")
    Do While strExtension <> ""
        Set srcWB = Workbooks.Open(FolderName & strExtension)
        For Each ws In Sheets
            With ws
                desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0) = .Range("A1")
                desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0) = .Range("A2")
                desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0) = .Range("A3")
                desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0) = .Range("A4")
            End With
        Next ws
        srcWB.Close False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
I tested the macro on some dummy files and it worked properly. Do you have data in the cells you want to copy.
 
Upvote 0
Yes, created a file to test it on. 4 Sheets with this on each sheet.

1574176874365.png
 
Upvote 0
Is that code in the destination workbook, or is it in a different workbook, such as your Personal.xlsb?
 
Upvote 0
Is that code in the destination workbook, or is it in a different workbook, such as your Personal.xlsb?

Good catch. It was in my Personal. Moved it to the workbook Sheet 1 and it worked. Thank you. This forum is great. Thanks again Mumps and Fluff.

VBA Code:
Sub CopyData()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWB As Workbook, ws As Worksheet
    Set desWS = ThisWorkbook.Sheets("Sheet1")
    Dim FolderName As String
    With Application.FileDialog(msoFileDialogFolderPicker)
       .AllowMultiSelect = False
       .Show
       FolderName = .SelectedItems(1) & "\"
    End With
    ChDir FolderName
    strExtension = Dir("*.xlsx")
    Do While strExtension <> ""
        Set srcWB = Workbooks.Open(FolderName & strExtension)
        For Each ws In Sheets
            With ws
                desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0) = .Range("A1")
                desWS.Cells(desWS.Rows.Count, "B").End(xlUp).Offset(1, 0) = .Range("A2")
                desWS.Cells(desWS.Rows.Count, "C").End(xlUp).Offset(1, 0) = .Range("A3")
                desWS.Cells(desWS.Rows.Count, "D").End(xlUp).Offset(1, 0) = .Range("A4")
            End With
        Next ws
        srcWB.Close False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
 
Upvote 0

Forum statistics

Threads
1,212,938
Messages
6,110,788
Members
448,297
Latest member
carmadgar

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top