VBA help - Getting data from all files in the same folder

A

asad

Well-known Member
Joined
Sep 9, 2008
Messages
1,434
Hi All,

I found the following code form Jerry Beaucaire's website:
Code: 
[B]CODE[/B]

[COLOR=#5F6A72][FONT=Arial][FONT='inherit']Option Explicit

Sub Consolidate()
[B]'Author:     Jerry Beaucaire'
'Date:       9/15/2009     (2007 compatible)  (updated 4/29/2011)
'Summary:    Merge files in a specific folder into one master sheet (stacked)
'            Moves imported files into another folder

Dim fName As String, fPath As String, fPathDone As String
Dim LR As Long, NR As Long
Dim wbData As Workbook, wsMaster As Worksheet

[B]'Setup
    Application.ScreenUpdating = False  [B]'speed up macro execution
    Application.EnableEvents = False    [B]'turn off other macros for now
    Application.DisplayAlerts = False   [B]'turn off system messages for now
    
    Set wsMaster = ThisWorkbook.Sheets("[B]Master")    [B]'sheet report is built into

With wsMaster
    If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
        .UsedRange.Offset(1).EntireRow.Clear
        NR = 2
    Else
        NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1    [B]'appends data to existing data
    End If

[B]'Path and filename (edit this section to suit)
    fPath = "[B]C:\2011\Files\"            [B]'remember final \ in this string
    fPathDone = fPath & "Imported\"     [B]'remember final \ in this string
    On Error Resume Next
        MkDir fPathDone                 [B]'creates the completed folder if missing
    On Error GoTo 0
    fName = Dir(fPath & "[B]*.xls*")        [B]'listing of desired files, edit filter as desired
[B]
'Import a sheet from found files
    Do While Len(fName) > 0
        If fName <> ThisWorkbook.Name Then              [B]'don't reopen this file accidentally
            Set wbData = Workbooks.Open(fPath & fName)  [B]'Open file

[B]        'This is the section to customize, replace with your own action code as needed
            LR = Range("A" & Rows.Count).End(xlUp).Row  [B]'Find last row
            [COLOR=#cc0000]Range("A1:A" & LR).EntireRow.Copy .Range("A" & NR)[/COLOR]
            wbData.Close False                                [B]'close file
            NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1  [B]'Next row
            Name fPath & fName As fPathDone & fName           [B]'move file to IMPORTED folder
        End If
[/B][/B][/B][/B][/B][/B][/B][/B][/B][/B][/B][/B][/B][/B][/B][/B][/B][/B][/B][/B][/B][/B][/B][/FONT][B][B][B][B][B][B][FONT='inherit']        fName = Dir                                       [B]'ready next filename
[/B][/FONT][B][FONT='inherit']    Loop
End With

ErrorExit:    [B]'Cleanup
    ActiveSheet.Columns.AutoFit
    Application.DisplayAlerts = True         [B]'turn system alerts back on
    Application.EnableEvents = True          [B]'turn other macros back on
    Application.ScreenUpdating = True        [B]'refreshes the screen
End Sub
[/B][/B][/B][/B][/FONT][/B][/B][/B][/B][/B][/B][/B]
[B][B][B][B][B][B][FONT='inherit']
[/FONT][/B][/B][/B][/B][/B][/B]

[/FONT][/COLOR]

And tried to change it to the following:
Code: 
Option Explicit

Sub Consolidate()
'Author:     Jerry Beaucaire'
'Date:       9/15/2009     (2007 compatible)  (updated 4/29/2011)
'Summary:    Merge files in a specific folder into one master sheet (stacked)
'            Moves imported files into another folder


Dim fName As String, fPath As String, fPathDone As String
Dim LR As Long, NR As Long
Dim wbData As Workbook, wsMaster As Worksheet


'Setup
    Application.ScreenUpdating = False  'speed up macro execution
    Application.EnableEvents = False    'turn off other macros for now
    Application.DisplayAlerts = False   'turn off system messages for now
    
    Set wsMaster = ThisWorkbook.Sheets("Master")    'sheet report is built into


With wsMaster
    If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
        .UsedRange.Offset(1).EntireRow.Clear
        NR = 2
    Else
        NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1    'appends data to existing data
    End If


'Path and filename (edit this section to suit)  [COLOR=#ff0000]<----------I have changed this part[/COLOR]
    fPath = ThisWorkbook.Path & "\"[COLOR=#FF0000]<----------[/COLOR][COLOR=#FF0000]I have changed this part[/COLOR]
    fPathDone = fPath & "Imported\"     'remember final \ in this string
    On Error Resume Next
        MkDir fPathDone                 'creates the completed folder if missing
    On Error GoTo 0
    fName = Dir(fPath & "*.xls*")        'listing of desired files, edit filter as desired


'Import a sheet from found files
    Dim ws As Worksheet
    For Each ws In wbData.Sheets(Array("ITB AM Shift Data", "ITB PM Shift Data"))[COLOR=#FF0000]<----------[/COLOR][COLOR=#FF0000]I have changed this part[/COLOR]
        LR = ws.Range("B" & ws.Rows.Count).End(xlUp).Row 'Find last row[COLOR=#FF0000]<----------[/COLOR][COLOR=#FF0000]I have changed this part, but this should be okay[/COLOR]
        If NR = 1 Then 'copy the data AND titles
            ws.Range("A10:A" & LR).EntireRow.Copy .Range("A" & NR)[COLOR=#FF0000]<----------[/COLOR][COLOR=#FF0000]I have changed this part, but this should be okay[/COLOR]
        Else 'copy the data only
            ws.Range("A10:A" & LR).EntireRow.Copy .Range("A" & NR)[COLOR=#FF0000]<----------[/COLOR][COLOR=#FF0000]I have changed this part, but this should be okay[/COLOR]
        End If
        NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'Next row
    Next ws


End With


ErrorExit:    'Cleanup
    ActiveSheet.Columns.AutoFit
    Application.DisplayAlerts = True         'turn system alerts back on
    Application.EnableEvents = True          'turn other macros back on
    Application.ScreenUpdating = True        'refreshes the screen
End Sub

I am getting error on the line
Code: 
    For Each ws In wbData.Sheets(Array("ITB AM Shift Data", "ITB PM Shift Data"))
Can someone please let me know what I have done wrong?
Thanks
Asad
 
Last edited:

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.
Sort by date Sort by votes
asad said:
I am getting error on the line
Code: 
    For Each ws In wbData.Sheets(Array("ITB AM Shift Data", "ITB PM Shift Data"))

Asad
Click to expand...

It looks like one of the lines of code you deleted (just above the line that errors out) set wbData. I think you need to add that line back in.
 
Upvote 0
variable wbData is a workbook - you have not specified which one

Your code needs to contain the equivalent of this line (which is included in the original code)
Code: 
Set wbData = Workbooks.Open(fPath & fName)  'Open file
 
Last edited:
Upvote 0
Hi Yongle,

I made the change that you had pointed out. I made some more changes. Now when I run the macro, it just goes in endless loop without giving me any result. I have to force shut Excel every time I run the macro.
can you please help me out again and let me know what is it that I did wrong in the code below:
Code: 
Option Explicit

Sub Consolidate()
'Author:     Jerry Beaucaire'
'Date:       9/15/2009     (2007 compatible)  (updated 4/29/2011)
'Summary:    Merge files in a specific folder into one master sheet (stacked)
'            Moves imported files into another folder


Dim fName As String, fPath As String, fPathDone As String
Dim LR As Long, NR As Long
Dim wbData As Workbook, wsMaster As Worksheet


'Setup
    Application.ScreenUpdating = False  'speed up macro execution
    Application.EnableEvents = False    'turn off other macros for now
    Application.DisplayAlerts = False   'turn off system messages for now
    
    Set wsMaster = ThisWorkbook.Sheets("Master")    'sheet report is built into


With wsMaster
        NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1    'appends data to existing data


'Path and filename (edit this section to suit)
    fPath = ThisWorkbook.Path & "\"
    fName = Dir(fPath & "*.xls*")        'listing of desired files, edit filter as desired


'Import a sheet from found files
    Do While Len(fName) > 0
        If fName <> ThisWorkbook.Name Then              'don't reopen this file accidentally
            Set wbData = Workbooks.Open(fPath & fName)  'Open file
                Dim ws As Worksheet
                    For Each ws In wbData.Sheets(Array("ITB AM Shift Data", "ITB PM Shift Data"))
                        LR = ws.Range("B" & ws.Rows.Count).End(xlUp).Row 'Find last row
                                ws.Range("A10:A" & LR).EntireRow.Copy .Range("A" & NR)
                        NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'Next row
                    Next ws
        End If
    Loop


End With


ErrorExit:    'Cleanup
    ActiveSheet.Columns.AutoFit
    Application.DisplayAlerts = True         'turn system alerts back on
    Application.EnableEvents = True          'turn other macros back on
    Application.ScreenUpdating = True        'refreshes the screen
End Sub

Thanks a lot for your help.
Asad
 
Upvote 0
Got it :). Here is the final code that works.
Code: 
Option Explicit

Sub Consolidate()
'Author:     Jerry Beaucaire'
'Date:       9/15/2009     (2007 compatible)  (updated 4/29/2011)
'Summary:    Merge files in a specific folder into one master sheet (stacked)
'            Moves imported files into another folder


Dim fName As String, fPath As String, fPathDone As String
Dim LR As Long, NR As Long
Dim wbData As Workbook, wsMaster As Worksheet


'Setup
    Application.ScreenUpdating = False  'speed up macro execution
    Application.EnableEvents = False    'turn off other macros for now
    Application.DisplayAlerts = False   'turn off system messages for now
    
    Set wsMaster = ThisWorkbook.Sheets("Master")    'sheet report is built into


With wsMaster
        NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1    'appends data to existing data


'Path and filename (edit this section to suit)
    fPath = ThisWorkbook.Path & "\"
    fName = Dir(fPath & "*.xls*")        'listing of desired files, edit filter as desired


'Import a sheet from found files
    Do While Len(fName) > 0
        If fName <> ThisWorkbook.Name Then              'don't reopen this file accidentally
            Set wbData = Workbooks.Open(fPath & fName)  'Open file
                Dim ws As Worksheet
                    For Each ws In wbData.Sheets(Array("ITB AM Shift Data", "ITB PM Shift Data"))
                        LR = ws.Range("B" & ws.Rows.Count).End(xlUp).Row 'Find last row
                                ws.Range("A10:A" & LR).EntireRow.Copy
                                .Range("A" & NR).PasteSpecial xlPasteValues
                        NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'Next row
                    Next ws
        End If
        fName = Dir
    Loop


End With


ErrorExit:    'Cleanup
    ActiveSheet.Columns.AutoFit
    Application.DisplayAlerts = True         'turn system alerts back on
    Application.EnableEvents = True          'turn other macros back on
    Application.ScreenUpdating = True        'refreshes the screen
End Sub
 
Upvote 0
Glad you got it sorted :)
Reading your code, I cannot spot where you are closing wbData. If you need it, use this within the Do loop
Code: 
wbData.Close False
 
Last edited:
Upvote 0
Yongle said:
Glad you got it sorted :)
Reading your code, I cannot spot where you are closing wbData. If you need it, use this within the Do loop
Code: 
wbData.Close False
Click to expand...
Thanks a lot for that last piece. That was the missing link. I was having to manually close all the open files (about 30 - 50) in each folder. You saved me a lot of extra work.
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question
VBA to extract data from multiple folders and add to a master workbook plus identifying tags
Replies
2
Views
852
John_w
J
2
  • Question
Selecting all files from folder by week number
Replies
0
Views
597
22gree
2
R
  • Solved
SaveAs method not actually saving, wrong sheets being deleted (1004 Error)
Replies
4
Views
393
Alex Blakenburg
A
R
  • Question
How to save all the Excel file in same folder with the given format
2
Replies
15
Views
901
ramya0313
R
G
  • Solved
Change Macro to import files from hyperlinks
2
Replies
12
Views
389
GarnesGambit
G

Forum statistics

Threads
1,214,534
Messages
6,120,080
Members
448,943
Latest member
sharmarick

Share this page

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