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.
 
Glad we could help & thanks for the feedback
 
Upvote 0

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
Some of the cells I am pulling from are blank and its causing the data not to align on the destination sheet. Each time there is a blank cell the next cell with data is pasted there. Is there a way to force each loop to stay on the same row?

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
 
Last edited:
Upvote 0
Glad we could help & thanks for the feedback
Glad we could help. :)

Some of the cells I am pulling from are blank and its causing the data not to align on the destination sheet. Each time there is a blank cell the next cell with data is pasted there. Is there a way to force each loop to stay on the same row?
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
How about
Rich (BB 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
    Dim NxtRw As Long
    
    NxtRw = destws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    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(NxtRw, "A").End(xlUp) = .Range("A1")
                desWS.Cells(NxtRw, "B").End(xlUp) = .Range("A2")
                desWS.Cells(NxtRw, "C").End(xlUp) = .Range("A3")
                desWS.Cells(NxtRw, "D").End(xlUp) = .Range("A4")
                NxtRw = NxtRw + 1
            End With
        Next ws
        srcWB.Close False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
How about
Rich (BB 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
    Dim NxtRw As Long
   
    NxtRw = destws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    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(NxtRw, "A").End(xlUp) = .Range("A1")
                desWS.Cells(NxtRw, "B").End(xlUp) = .Range("A2")
                desWS.Cells(NxtRw, "C").End(xlUp) = .Range("A3")
                desWS.Cells(NxtRw, "D").End(xlUp) = .Range("A4")
                NxtRw = NxtRw + 1
            End With
        Next ws
        srcWB.Close False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
I'm getting a run-time error 424
Object required
 
Upvote 0
Oops, it should be
Rich (BB code):
            With ws
                desWS.Cells(NxtRw, "A") = .Range("A1")
                desWS.Cells(NxtRw, "B") = .Range("A2")
                desWS.Cells(NxtRw, "C") = .Range("A3")
                desWS.Cells(NxtRw, "D") = .Range("A4")
                NxtRw = NxtRw + 1
            End With
Also please do not quote entire posts, just use the Reply window below the last post. :)
 
Upvote 0
Oops, it should be
Rich (BB code):
            With ws
                desWS.Cells(NxtRw, "A") = .Range("A1")
                desWS.Cells(NxtRw, "B") = .Range("A2")
                desWS.Cells(NxtRw, "C") = .Range("A3")
                desWS.Cells(NxtRw, "D") = .Range("A4")
                NxtRw = NxtRw + 1
            End With
Also please do not quote entire posts, just use the Reply window below the last post. :)

Gives me the same error
 
Upvote 0
In that case what line gives the error?
Once again please use the reply window below the last post, rather than clicking on the reply icon
 
Upvote 0

Forum statistics

Threads
1,213,520
Messages
6,114,099
Members
448,548
Latest member
harryls

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