dma70
asked on
Does anyone have a sample vb script (or vba) that opens every .xls and .xlsx file in a directory and extracts certain cells
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.
ASKER
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
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.
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.
ASKER
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.
Let me know if you need more help
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
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 optionsWith ThisWorkbook.Worksheets(1) ''/// the first Tab
With ThisWorkbook.Worksheets("Data") ''/// all sheets named Data
With ThisWorkbookSheet1 ''/// uses the sheet's Codename
Let me know if you need more help
ASKER
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
Sorry I misunderstood! Let me see what I can do on my own, but might take you up on your offer. thank you
Dennis
ASKER
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
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
ASKER
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
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
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"
ASKER
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("S heet1")
Set rRng = .Range("b2,j2,s2").Current Region ''///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,S 2")
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
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("S
Set rRng = .Range("b2,j2,s2").Current
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,S
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?
ASKER
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.
Notice that I changed your line referring to "A1" (Set rRng = .Range...) with "B2, J2, S2". Not sure if I did that correctly.
ASKER
Here is error message
2016-11-02_10-54-32.pdf
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
ASKER
Roy: Still getting the same error. Debug points to this line:
rToCopy.Copy rNextCl.Offset(, 1)
rToCopy.Copy rNextCl.Offset(, 1)
ASKER
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
skews081216.xls
skews081516.xls
skews081116.xls
I'll take a look later
SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
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
~bp
Open in new window