VBA to extract data from multiple files in a folder

[MOB]

I have several files in C:\MOB

From each spreadsheet, I want to copy the data from Columns A and B, starting from row 6, and ending at the last non-empty cell in column A.

This data should be pasted into another master spreadsheet, and repeated for each file - ideally being pasted in such a way as to keep adding to the bottom of the master list each time.

Is this possible?

 

[hiker95]

MOB,

See if this helps you get started in the right direction:

WBs to 1 Sheet
https://sites.google.com/a/madrocke.../merge-functions/consolidate-wbs-to-one-sheet

 

[MOB]

That pretty much does what I need.

The only thing I need to change is when it copies the data over, it is copying formulae, can it be changed to paste values only?

I can't see any reference to when it pastes it!

TIA

 

[hiker95]

MOB,

Please post the code that you are now using.

If posting VBA code, please use Code Tags, see below in my Signature block: If posting VBA code, please use Code Tags - like this

 

[MOB]

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
        Cells.Select
        Selection.UnMerge
        .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)
    fPath = "C:\Documents and Settings\mark o'brien\Desktop\Nov11\"   'remember final \ in this string
    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
    Do While Len(fName) > 0
        If fName <> ThisWorkbook.Name Then              'don't reopen this file accidentally
            Set wbData = Workbooks.Open(fPath & fName)  'Open file

        'This is the section to customize, replace with your own action code as needed
            LR = Range("A" & Rows.Count).End(xlUp).Row  'Find last row
            Range("A1:A" & LR).EntireRow.Copy .Range("A" & NR)
            wbData.Close False                                'close file
            NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1  'Next row
            Name fPath & fName As fPathDone & fName           'move file to IMPORTED folder
            fName = Dir                                       'ready next filename
        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

 

[hiker95]

MOB,


Try the following change to the below section of code:

'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

        'This is the section to customize, replace with your own action code as needed
            LR = Range("A" & Rows.Count).End(xlUp).Row  'Find last row
            

            ''Change the next line of code
            ''Range("A1:A" & LR).EntireRow.Copy .Range("A" & NR)
            
            ''To two lines of code
            Range("A1:A" & LR).EntireRow.Copy
            .Range("A" & NR).PasteSpecial xlPasteValues

            
            wbData.Close False                                'close file
            NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1  'Next row
            Name fPath & fName As fPathDone & fName           'move file to IMPORTED folder
            fName = Dir                                       'ready next filename
        End If
    Loop

 

[MOB]

Thats great, thanks

One last issue - with the above code it copies data from the tab that was active when the file was saved.

How can I change it so that it always copies from a tab called "Payment Schedule" instead?

 

[hiker95]

MOB,


The two changes to the original code have been incorporated into the new macro (see the bold code below).


The code has not been tested.


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Explicit
Sub ConsolidateV2()
'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
        Cells.Select
        Selection.UnMerge
        .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)
    fPath = "C:\Documents and Settings\mark o'brien\Desktop\Nov11\"   'remember final \ in this string
    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
    Do While Len(fName) > 0
        If fName <> ThisWorkbook.Name Then              'don't reopen this file accidentally
            Set wbData = Workbooks.Open(fPath & fName)  'Open file

        'This is the section to customize, replace with your own action code as needed
        
        'How can I change it so that it always copies from a tab called "Payment Schedule" instead?

            LR = Worksheets("Payment Schedule").Range("A" & Rows.Count).End(xlUp).Row  'Find last row
            Worksheets("Payment Schedule").Range("A1:A" & LR).EntireRow.Copy
            
            .Range("A" & NR).PasteSpecial xlPasteValues

            wbData.Close False                                'close file
            NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1  'Next row
            Name fPath & fName As fPathDone & fName           'move file to IMPORTED folder
            fName = Dir                                       'ready next filename
        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

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm


Then run the ConsolidateV2 macro.

 

[asbey]

Hi there
The code here works perfectly, but I'm searching for one more addition.
My filenames have some valuable information in them (batchnumber, timestamp, operator) so I would like that the filename is being shown above/under the extracted data of each excelfile.
Thank you for your time.

 

[hiker95]

My filenames have some valuable information in them (batchnumber, timestamp, operator) so I would like that the filename is being shown above/under the extracted data of each excelfile.

asbey,

Welcome to the MrExcel forum.

It is always easier to help and test possible solutions if we could work with your actual file.

Perhaps you could upload a copy of one of your files to a free site such as www.box.com or www.dropbox.com.

Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here.

Include a detailed explanation of what you would like to do referring to specific cells and worksheets.

If the workbook contains confidential information, you could replace it with generic data.