Does anyone have a sample vb script (or vba) that opens every .xls and .xlsx file in a directory and extracts certain cells

Is the information in the same cells? This code shouldn't be too difficult to change, but let me know if you need help with it.

Option Explicit


'---------------------------------------------------------------------------------------
' Module    : Data
' Author    : Roy Cox (royUK)
' Website   : for more examples and Excel Consulting
' Date      : 19/11/2011
' Purpose   : Combine data from several workbooks
' Disclaimer: Disclaimer; This code is offered as is with no guarantees. You may use it in your
'             projects but please leave this header intact.
 
'---------------------------------------------------------------------------------------



Sub CombineData()
    Dim oWbk As Workbook
    Dim rRng As Range
    Dim rToCopy As Range
    Dim rNextCl As Range
    Dim lCount As Long
    Dim bHeaders As Boolean
    Dim sFil As String
    Dim sPath As String

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        '   On Error GoTo exithandler
        ' assumes workbooks are in a sub folder named "Data"
        sPath = ThisWorkbook.Path & Application.PathSeparator & "Data"
        ChDir sPath
        sFil = Dir("*.xl**")    'file type
        Do While sFil <> ""    'will start LOOP until all files in folder sPath have been looped through

            With ThisWorkbook.Worksheets(1)
                Set rRng = .Range("A1").CurrentRegion @@///change range here
                If rRng.Cells.Count = 0 Then
                    'no data in master sheet
                    bHeaders = False
                Else: bHeaders = True
                End If

                Set oWbk = Workbooks.Open(sPath & Application.PathSeparator & sFil)    'opens the file
                'A1 must be within the data, if not amend the Range below
                Set rToCopy = oWbk.ActiveSheet.Range("A1").CurrentRegion
                If Not bHeaders Then
                    Set rNextCl = .Cells(1, 1)
                    bHeaders = True
                Else: Set rNextCl = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
                    'headers exist so don't copy
                    Set rToCopy = rToCopy.Offset(1, 0).Resize(rToCopy.Rows.Count - 1, _
                                                              rToCopy.Columns.Count)
                End If
                rToCopy.Copy rNextCl
            End With
            oWbk.Close False     'close source workbook
            sFil = Dir
        Loop    ' End of LOOP
        
exithandler:
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
End Sub

Select allOpen in new window

Roy:  Thank you for this.   I am not that familiar with the code.   This is vba right? not vbs.    A few questions.   And yes, the information I wish to retrieve are three pieces of data and they reside in the same cell addresses in all the files.


1. If it is VBA do you think its ok to do this in excel with hundreds of files?
2. Where exactly in the code are you extracting the value a particular cell, and what variable contains the name of the file?
3. Will the program know to look at a particular worksheet (e.g. Sheet1) in all the files?

thanks

Dennis

You use VBA (VisualBasic for Applications) with MS Office programs like Excel. VBS is a different coding script.

TH ecode currently will open all workbooks in a specific folder, copy a range from within a sheet to a master workbook.

It can be adapted to suit but I would need to know what data is being copied and where to. Attach an example of the source workbook and the workbook to store the data.

I do appreciate the code, will be trying it out and will close out this question.  But before I do, would you mind just answering the 3 questions I asked.   I think that will certainly help me understand the code a lot better.

I was actually offering to help you to amend the code.

1. It may be slow with hundreds of files, but it should work.
2. The below line sets the Range to copy.

Set rRng = .Range("A1").CurrentRegion @@///change range here

Select allOpen in new window

3.You would set the specific sheet if the workbooks contain more than 1 sheet, all the sheets would ideally be the same, i.e. all Sheet 1 or the same position in the workbook. Here's 3 options

With ThisWorkbook.Worksheets(1) ''/// the first Tab

Select allOpen in new window

With ThisWorkbook.Worksheets("Data") ''/// all sheets named Data

Select allOpen in new window

With ThisWorkbookSheet1 ''/// uses the sheet's Codename

Select allOpen in new window

Let me know if you need more help

Hi Roy:

Sorry I misunderstood!   Let me see what I can do on my own, but might take you up on your offer.  thank you

Dennis

Hi Roy:

Sorry about the delay - I am doing several things at once.    If you could oblige, I am looking to simply extract the value from 3 cells:  B2, J2 and S2.  These values are dates.   The format in each input file is the same.  The inputs are all the excel files in a given directory P:/test2/pydev/ (filename1,xlsx, filename2.xls...). I would like to write an output file, call it output.xlsx in the upper-level directory P:/test2/  with the following format:

filename1, value in B2, value in J2, value in S2
filename2, value in B2, value in J2, value in S2
.
.
.

Could you perhaps write that into you sample code.   I am confused about how to use Range and dont see where the read information is stored.   The data is all in Sheet1 of each file.

thank you,

Dennis

I'll take a look after work

Try this, let me know if it needs amending

Option Explicit


'---------------------------------------------------------------------------------------
' Module    : Data
' Author    : Roy Cox (royUK)
' Website   : for more examples and Excel Consulting
' Date      : 19/11/2011
' Purpose   : Combine data from several workbooks
' Disclaimer: Disclaimer; This code is offered as is with no guarantees. You may use it in your
'             projects but please leave this header intact.

'---------------------------------------------------------------------------------------



Sub CombineData()
    Dim oWbk As Workbook
    Dim rRng As Range
    Dim rToCopy As Range
    Dim rNextCl As Range
    Dim lCount As Long
    Dim bHeaders As Boolean
    Dim sFil As String
    Dim sPath As String

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        '   On Error GoTo exithandler
        ' assumes workbooks are in a sub folder named "Data"
        sPath = "P:/test2/pydev/"
        ChDir sPath
        sFil = Dir("*.xl**")    'file type
        Do While sFil <> ""    'will start LOOP until all files in folder sPath have been looped through

            With ThisWorkbook.Worksheets("Sheet1")
                Set rRng = .Range("A1").CurrentRegion    ''///change range here
                If rRng.Cells.Count = 0 Then
                    'no data in master sheet
                    bHeaders = False
                Else: bHeaders = True
                End If

                Set oWbk = Workbooks.Open(sPath & Application.PathSeparator & sFil)    'opens the file
                'A1 must be within the data, if not amend the Range below
                Set rToCopy = oWbk.Sheet1.Range("B2,J2,S2")
                If Not bHeaders Then
                    Set rNextCl = .Cells(1, 1)
                    bHeaders = True
                Else: Set rNextCl = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
                End If
                ''/// add file name
                rNextCl.Value = oWbk.Name
                ''/// copy cells next to file name
                rToCopy.Copy rNextCl.Offset(, 1)
            End With
            oWbk.Close False     'close source workbook
            sFil = Dir
        Loop    ' End of LOOP

exithandler:
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
End Sub

Select allOpen in new window

I tried running your code.   Got this error, picture enclosed.    Any idea what the problem is.   I see no reason for the file to be open by another program.
Oct-31--2016-4_43_57-PM.pdf

Looks like forward slashes in the pathname rather than backwards one, not sure if that could be a problem?

And you shouldn't have any double backslashes together like you do after P:.

~bp

The Path was provided by the OP so I used that. It's usually best to use Application.FileSeparator as I did in my original code, this works in any situation where the separator may be different

ThisWorkbook.Path & Application.PathSeparator & "Data"

Select allOpen in new window

Progress:  File now opening.   Now got stuck trying to write cell contents (bold line) after file name.   Here is how I modified code:  

Did I so something wrong in modifying the code?

Option Explicit


'---------------------------------------------------------------------------------------
' Module    : Data
' Author    : Roy Cox (royUK)
' Website   : for more examples and Excel Consulting
' Date      : 19/11/2011
' Purpose   : Combine data from several workbooks
' Disclaimer: Disclaimer; This code is offered as is with no guarantees. You may use it in your
'             projects but please leave this header intact.

'---------------------------------------------------------------------------------------



Sub CombineData()
    Dim oWbk As Workbook
    Dim rRng As Range
    Dim rToCopy As Range
    Dim rNextCl As Range
    Dim lCount As Long
    Dim bHeaders As Boolean
    Dim sFil As String
    Dim sPath As String

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        '   On Error GoTo exithandler
        ' assumes workbooks are in a sub folder named "Data"
        sPath = "P:\\test2\pydev\data"
        ChDir sPath
        sFil = Dir("*.xl**")    'file type
        Do While sFil <> ""    'will start LOOP until all files in folder sPath have been looped through

            With ThisWorkbook.Worksheets("Sheet1")
                Set rRng = .Range("b2,j2,s2").CurrentRegion    ''///change range here
                If rRng.Cells.Count = 0 Then
                    'no data in master sheet
                    bHeaders = False
                Else: bHeaders = True
                End If

                Set oWbk = Workbooks.Open(sPath & Application.PathSeparator & sFil)    'opens the file
                'A1 must be within the data, if not amend the Range below
                'Set rToCopy = oWbk.Sheet1.Range("B2,J2,S2")
                If Not bHeaders Then
                    Set rNextCl = .Cells(1, 1)
                    bHeaders = True
                Else: Set rNextCl = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
                End If
                ''/// add file name
                rNextCl.Value = oWbk.Name
                ''/// copy cells next to file name
                rToCopy.Copy rNextCl.Offset(, 1)
            End With
            oWbk.Close False     'close source workbook
            sFil = Dir
        Loop    ' End of LOOP

exithandler:
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
End Sub

What is actually copying?

Nothing,  I get the first filename printed, then it stops with an error and does not show anything after the filename.  

Notice that I changed your line referring to "A1" (Set rRng = .Range...) with "B2, J2, S2".   Not sure if I did that correctly.

Here is error message
2016-11-02_10-54-32.pdf

I think I've found my error. There was a typo, try this amended code.

Option Explicit




'---------------------------------------------------------------------------------------
' Module    : Data
' Author    : Roy Cox (royUK)
' Website   : for more examples and Excel Consulting
' Date      : 19/11/2011
' Purpose   : Combine data from several workbooks
' Disclaimer: Disclaimer; This code is offered as is with no guarantees. You may use it in your
'             projects but please leave this header intact.

'---------------------------------------------------------------------------------------



Sub CombineData()
    Dim oWbk As Workbook
    Dim rRng As Range, rToCopy As Range, rNextCl As Range
    Dim bHeaders As Boolean
    Dim sFil As String, sPath As String

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        '   On Error GoTo exithandler
        ' assumes workbooks are in a sub folder named "Data"
        sPath = "P:\\test2\pydev\data"
        ChDir sPath
        sFil = Dir("*.xl**")    'file type
        Do While sFil <> ""    'will start LOOP until all files in folder sPath have been looped through

            With ThisWorkbook.Worksheets("Sheet1")
                Set rRng = .Range("b2,j2,s2")   ''///change range here
                If rRng.Cells.Count = 0 Then
                    'no data in master sheet
                    bHeaders = False
                Else: bHeaders = True
                End If

                Set oWbk = Workbooks.Open(sPath & Application.PathSeparator & sFil)    'opens the file
                'A1 must be within the data, if not amend the Range below
                'Set rToCopy = oWbk.Sheet1.Range("B2,J2,S2")
                If Not bHeaders Then
                    Set rNextCl = .Cells(1, 1)
                    bHeaders = True
                Else: Set rNextCl = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
                End If
                ''/// add file name
                rNextCl.Value = oWbk.Name
                ''/// copy cells next to file name
                rToCopy.Copy rNextCl.Offset(, 1)
            End With
            oWbk.Close False     'close source workbook
            sFil = Dir
        Loop    ' End of LOOP

exithandler:
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
End Sub

Select allOpen in new window

Roy:  Still getting the same error.   Debug points to this line:

rToCopy.Copy rNextCl.Offset(, 1)

Here are three test files you could try.   It opened the first one among the three, wrote the filename in the current worksheet in cell A5 then produced the error message.   thank you
skews081216.xls
skews081516.xls
skews081116.xls

I'll take a look later

Both solutions worked.  Roy was more persistent and Bill was very helpful catching the error in the file syntax and offering a VBS solution, which may work better in the long run with so a large number of files.    I really appreciate all the patience.   In retrospect it seems like it  would have helped to send the sample files earlier.

Pleased to help

Welcome, glad that was helpful and thanks for the feedback.

~bp