Solved

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

Posted on 2016-10-25
25
60 Views
Last Modified: 2016-11-04
I have over 100 excel files in a directory would all have the same format.   I would like to extract a 3 or more particular cell contents then write those extracted values in a row along with the filename and put that in a new excel file.
0
Comment
Question by:dma70
  • 11
  • 11
  • 3
25 Comments
 
LVL 17

Expert Comment

by:Roy_Cox
ID: 41858963
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

Open in new window

0
 

Author Comment

by:dma70
ID: 41859232
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
0
 
LVL 17

Expert Comment

by:Roy_Cox
ID: 41859751
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.
0
 

Author Comment

by:dma70
ID: 41860343
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.
0
 
LVL 17

Expert Comment

by:Roy_Cox
ID: 41860640
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

Open 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

Open in new window

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

Open in new window

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

Open in new window


Let me know if you need more help
0
 

Author Comment

by:dma70
ID: 41860659
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
0
 

Author Comment

by:dma70
ID: 41862948
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
0
 
LVL 17

Expert Comment

by:Roy_Cox
ID: 41863399
I'll take a look after work
0
 
LVL 17

Expert Comment

by:Roy_Cox
ID: 41864939
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

Open in new window

0
 

Author Comment

by:dma70
ID: 41867561
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
0
 
LVL 51

Expert Comment

by:Bill Prew
ID: 41867566
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
0
 
LVL 17

Expert Comment

by:Roy_Cox
ID: 41867946
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"

Open in new window

0
What Is Threat Intelligence?

Threat intelligence is often discussed, but rarely understood. Starting with a precise definition, along with clear business goals, is essential.

 

Author Comment

by:dma70
ID: 41868592
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
0
 
LVL 17

Expert Comment

by:Roy_Cox
ID: 41868802
What is actually copying?
0
 

Author Comment

by:dma70
ID: 41870114
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.
0
 

Author Comment

by:dma70
ID: 41870436
Here is error message
2016-11-02_10-54-32.pdf
0
 
LVL 17

Expert Comment

by:Roy_Cox
ID: 41870744
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

Open in new window

0
 

Author Comment

by:dma70
ID: 41872523
Roy:  Still getting the same error.   Debug points to this line:

rToCopy.Copy rNextCl.Offset(, 1)
0
 

Author Comment

by:dma70
ID: 41872533
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
0
 
LVL 17

Expert Comment

by:Roy_Cox
ID: 41872546
I'll take a look later
0
 
LVL 51

Assisted Solution

by:Bill Prew
Bill Prew earned 200 total points
ID: 41872646
As an alternative, here is a standalone VBS script that you could try, worked well here in testing.  It requires Excel to be installed on the machine you invoke this on.  Either from a command line or a BAT file run as a VBS script as follows.  Make sure you check the folder and output file names to make sure they are right.  The output will be in a CSV text file, which will open in Excel just as easily as an XLS file would so that seemed simpler.

cscript EE28978708.vbs

' EE28978708

' Require variables to be defined
Option Explicit

' Define Needed constants
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8

Dim objFSO, objFolder, objFile, objOutFile
Dim strScanFolder, strOutFile
Dim objExcel, objMaster, objSheet

' Create file system object
Set objFSO = CreateObject("Scripting.FileSystemObject")

' Define folder to scan, and output data file (CSV)
strScanFolder = objFSO.GetAbsolutePathName("P:\test2\pydev\data")
strOutFile = objFSO.GetAbsolutePathName("P:\test2\pydev\output.csv")

' Make sure folder exists, quit if not
If Not objFSO.FolderExists(strScanFolder) Then
   Wscript.Echo "*ERROR* Scan folder does not exist: " & strScanFolder
   Wscript.Quit
End If

' Open Excel, hide it
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False

' Access folder to Scan
Set objFolder = objFSO.GetFolder(strScanFolder)

' Open output file, add header line
Set objOutFile = objFSO.OpenTextFile(strOutFile, ForWriting, True)
objOutFile.WriteLine Quote("Filename") & "," & Quote("B2") & "," & Quote("J2") & "," & Quote("S2")

' Check each file in folder
For Each objFile in objFolder.Files
   ' See if it's an Excel file
   If Left(LCase(objFSO.GetExtensionName(objFile.Name)), 3) = "xls" Then
      ' Open this file in Excel, reference first sheet
      Set objMaster = objExcel.Workbooks.Open(objFile.Path, False, False)
      Set objSheet = objMaster.Sheets("Sheet1")

      ' Write data from sheet to output file
      objOutFile.WriteLine Quote(objFile.Name) & "," & _
                           objSheet.Range("B2").Value & "," & _ 
                           objSheet.Range("J2").Value & "," & _ 
                           objSheet.Range("S2").Value

      ' Close Excel file
      objMaster.Close False
      Set objSheet = Nothing
      Set objMaster = Nothing
   End If
Next

' Close output file, close Excel, end
objOutFile.Close
objExcel.Quit
Wscript.Quit


' Add surrounding double quotes to a string
Function Quote(s)
   Quote = Chr(34) & s & Chr(34)
End Function

Open in new window

~bp
0
 
LVL 17

Accepted Solution

by:
Roy_Cox earned 300 total points
ID: 41873506
This seems to be working now. I've switched off asking to update links as well

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 oWs As Worksheet
    Dim 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
        .AskToUpdateLinks = False
        '   On Error GoTo exithandler
        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

            Set oWbk = Workbooks.Open(sPath & Application.PathSeparator & sFil)    'opens the file
            Set oWs = oWbk.Sheets("Sheet1")

            With ThisWorkbook.Worksheets("Sheet1")
                If Not bHeaders Then
                    Set rNextCl = .Cells(.Rows.Count, 1).End(xlUp)    '.Offset(1)
                    If rNextCl.Row = 1 Then
                        Set rNextCl = .Cells(1, 1)
                        bHeaders = True
                    End If
                Else: Set rNextCl = .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
                End If

                ''/// add file name
                rNextCl.Value = oWbk.Name
                ''/// copy cells next to file name
                rNextCl.Offset(, 1) = oWs.Range("b2").Value
                rNextCl.Offset(, 2) = oWs.Range("j2").Value
                rNextCl.Offset(, 3) = oWs.Range("s2").Value
            End With
            oWbk.Close False     'close source workbook
            sFil = Dir

        Loop    ' End of LOOP

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

Open in new window

0
 

Author Closing Comment

by:dma70
ID: 41874379
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.
0
 
LVL 17

Expert Comment

by:Roy_Cox
ID: 41874392
Pleased to help
0
 
LVL 51

Expert Comment

by:Bill Prew
ID: 41874400
Welcome, glad that was helpful and thanks for the feedback.

~bp
0

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

Introduction While answering a recent question (http:/Q_27311462.html), I created an alternative function to the Excel Concatenate() function that you might find useful.  I tested several solutions and share the results in this article as well as t…
This article is the result of a quest to better understand Task Scheduler 2.0 and all the newer objects available in vbscript in this version over  the limited options we had scripting in Task Scheduler 1.0.  As I started my journey of knowledge I f…
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.

743 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

15 Experts available now in Live!

Get 1:1 Help Now