Get Data From Closed Workbooks

Hi All,

Thanks to Ron De Bruin, I got below code from one of his sample ADO Tester.

This VBA extract data only from the sheet name "Sheet1" & the range A1:C1, where as I have 10 different sheets with different names and which are updated daily, how can I extract data from all the 10 sheets with their sheet name in first column and their last row data of Row B,C,D,E,F & AJ.
[VBA]Sub GetData_Example6()
Dim MyPath As String
Dim FilesInPath As String
Dim sh As Worksheet
Dim MyFiles() As String
Dim Fnum As Long
Dim rnum As Long
Dim destrange As Range

MyPath = "C:\Test" ' <<<< Change

'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

On Error GoTo CleanUp
Application.ScreenUpdating = False

'Add worksheet to the Activeworkbook and use the Date/Time as name
Set sh = ActiveWorkbook.Worksheets.Add
sh.Name = Format(Now, "dd-mmm-yy")

'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop

'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)

'Find the last row with data
rnum = LastRow(sh)

'create the destination cell address
Set destrange = sh.Cells(rnum + 1, "A")

' Copy the workbook name in Column E
sh.Cells(rnum + 1, "E").Value = MyPath & MyFiles(Fnum)

'Get the cell values and copy it in the destrange
'Change the Sheet name and range as you like
GetData MyPath & MyFiles(Fnum), "Sheet1", "A1:C1", destrange, False, False
Next
End If

CleanUp:
Application.ScreenUpdating = True
End Sub


[/VBA]

Hi There,

Sorry can you clarify, you want to extract the data in columns A- AJ and the sheet name?

i would use something like

isheetno = 1
do until isheetno>workbooks(1).sheets(isheetno).count

sSheetname workbooks(1).sheets(isheetno).name
'copy this info
workbooks(1).sheets(isheetno).range("A1:AJ10000").copy
'Paste this information where ever you want or collect it in an array

iSheetno = iSheetno+1
loop

Hi Nash,

Thanks for your response.

First I would like to extract the sheet name of all the 10 sheets of that workbook in the first column of the new worksheeet created with date.

Then I would to extract data from the last row of column; B, C, D, F & AJ of the worksheet in the folder C:/Test not from A to AJ.

It would be additional help if you could loop above criteria from all the worksheet in that folder.

If possible please include this code with the above code.

I think it'd be easier to just have the macro open each of the workbooks, extract the data, store it in the original, and then close the data workbook.

Is there a reason why you would want to keep it closed?

Paul

Because of the file size, it has 1000 rows in each worksheet. it takes a while to open each workbook, that's why I dont want it to be opened and execute the rules I would like to have.

There appears to be confusion between WorkSheets and WorkBooks.
Are you working with 10 Workbooks with one Worksheet in each or some other setup?

I am working on 10 different excel files(*.xls) each one has 15-20 sheets.

Quote:

---

Originally Posted by Shums

Hi Nash,

Thanks for your response.

First I would like to extract the sheet name of all the 10 sheets of that workbook in the first column of the new worksheeet created with date.

Then I would to extract data from the last row of column; B, C, D, F & AJ of the worksheet in the folder C:/Test not from A to AJ.

It would be additional help if you could loop above criteria from all the worksheet in that folder.

If possible please include this code with the above code.

---

to extract the sheet name
this wil place the sheet names in the column A

isheetno = 1
do until isheetno>sheets.count
cells(isheetno,1) = sheets(isheetno).name

isheetno = isheetno +1
loop

I'm not sure I understand what else you need doing...

to put different column values in a string use something like

sString = cells(row, colnumber1) &" "& cells(row, colnumber1)

then if you wanted to you could write them to a txt file using


Dim fNum
fNum = FreeFile()
Open "C:\textfile.txt" For Output As fNum
Print #fNum, sString
Close #fNum

Using the GetData method will not meet your needs unless you import each sheet to a sheet in the master workbook, get what you need and then repeat. Even then you will now know how many sheets are in the workbook. To do it all via closed workbooks can be done with ADO but that is fairly involved. That method may not work for all versions of Windows and Excel.

You are better off just opening the files and doing it. I don't think that it will take long to open the files and even if it does, it will probably not take that long. Before working on it, please explain more. One checks for the last row with data in each sheet in columns B,C,D,E,F & AJ. You put the workbook name into the master workbooks column E. You put the sheetname into column A of the master workbook. Where will the data from B,C,D,E,F & AJ go?

Hi Mr. Kenneth,

Its very good to see you again to help me. Last time you helped me a lot in below thread:
http://www.vbaexpress.com/forum/show...t=38267&page=2
I would request you to help me again with this.

For this thread, I am attaching the result output I would like to have.

These data must be extracted from the folder "C:/Test", which has 2 different files and each file contains 9-10 different sheets(which in attached file is the scrip code column). The data Open(B Column), High(C Column), Low(D Column), Close(E Column), Volume(F Column) & RSI(AJ Column) are their today's date data. As I mentioned earlier, I am updating all these sheets on daily basis, that's why I want data of their last row.

Hope its clear, still you need any clarification please let me know, I need such assistant very desperately.

I would request you all to look on my other thread as well, there also I need you help.

Thanking you in advance.

The sheet name is Sr. No.? Where does Scrip Code come from? Is there one of the columns that will always have data for the last row, B,C,D,E,F & AJ?

Sr. No is the serial number which would automatically add up as it extract scrip code which are Sheet Name in those files. Yes all those sheet name(scrip code) has a data till last row.

I wanted to add example file, but this forum doesn't allow me to add file above 1MB. So I deleted some of the sheets and some hidden column and formulas.

If you can give me code for both the attached files, then I will change in my original file as per my requirement.

Final Summary workbook will be out of the folder C:\Test.
I would like to have this vba in Final Summary workbook:
1. First it must create a new worksheet with today's date.
2. It must extract all the sheet names of all the workbook in the folder C:\Test.
3. It must extract the data of last row of column B,C,D,E,F & AJ from all the sheets of all the workbook in the folder C:\Test

I know this is very easy task for you Mr. Kenneth. I hope you would solve this very soon.

Hi Shums,

You may wish to consider creating a few source files, a destination file showing the desired results, and zip them. VBAX allows .zip files, which can be a great help in demonstrating what we are trying to do.

Mark

Hi Mark,

Please see attached zip file for just testing.
Final Summary.xls will be out from this folder and which must have desired code which will run in the folder C:\Test within all the workbook and all worksheet.

Hope it clarifies max.

Your examples do not show what you said that you wanted in post 3 of this thread. Your example files put the slave data from last consecutive row of columns B:G to the master column's C:H. Column AJ in the slave data files have no data.

The task is very easy for many here. It is always best to fully define the problem before wasting effort.

Hi Mr. Kenneth,

I know task is very easy for experts like you, but for novice like us is like breaking our heads against wall. http://www.vbaexpress.com/forum/imag...s/banghead.gif
There are many different codes I looked for, but they doesn't match my requirement.

Because of the restrictions, I cannot attached original file, that's why I deleted formulated column in BSE-Auto & BSE-CD, just kept the column header which I need to have in my Final Summary.

Final Summary is just for your reference, what I would like to have automated, instead of going to every sheet like BSE-Auto and copying last row for required column header and pasting value of 10 different sheets in my Final Summary with new dates.

I desperately need your help.

The first part is to add the Speedup Module as I explained in past threads and the KB. Then add the code following this to another Module.

The last module also shows how to get the file list that you can use for your other projects. The GetMyData() shows how to iterate through both the workbooks found and their worksheets.

Modify the pFolder path and the master and slave arrays of column names to suit.

[VBA]Option Explicit
'http://vbaexpress.com/kb/getarticle.php?kb_id=1035
Public glb_origCalculationMode As Integer

Sub SpeedOn(Optional StatusBarMsg As String = "Running macro...")
glb_origCalculationMode = Application.Calculation
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Cursor = xlWait
.StatusBar = StatusBarMsg
.EnableCancelKey = xlErrorHandler
End With
End Sub

Sub SpeedOff()
With Application
.Calculation = glb_origCalculationMode
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.CalculateBeforeSave = True
.Cursor = xlDefault
.StatusBar = False
.EnableCancelKey = xlInterrupt
End With
End Sub[/VBA]

[VBA]Option Explicit

' http://www.vbaexpress.com/forum/showthread.php?p=257028
Sub GetMyData()
Dim pFolder As String, fileList As Variant, f As Variant
Dim cr As Long, cs As Worksheet, ws As Worksheet
Dim slaveWB As Workbook, slaveCols() As Variant, masterCols() As Variant
Dim i As Integer, lr As Long

On Error GoTo TheEnd
SpeedOn

'Set the parent folder of slave workbooks to process.
pFolder = ThisWorkbook.Path & "\" '<-------- Change as needed.

' Set the column names for the slave and master workbooks with 1-1 match.
' Both arrays must have the same number of elements.
masterCols() = Array("C", "D", "E", "F", "G", "H")
slaveCols() = Array("B", "C", "D", "E", "F", "G")

'Add a new sheet and name it with today's date:
Set cs = Worksheets.Add(After:=Worksheets(Worksheets.Count), Count:=1)
cs.Name = Format(Date, "dd-MMM-yy")

' Add header:
Range("A1").Value = "Sr. No."
Range("B1").Value = "Scrip Code"
Range("C1").Value = "Open"
Range("D1").Value = "High"
Range("E1").Value = "Low"
Range("F1").Value = "Close"
Range("G1").Value = "Volume"
Range("H1").Value = "RSI"
Range("A1:H1").HorizontalAlignment = xlCenter
Range("A1:H1").Font.Bold = True
Range("A2").Select
ActiveWindow.FreezePanes = True

' Open each workbook except thisworkbook and get the data.
cr = 1
fileList = GetFileList(pFolder & "*.xl*")
For Each f In fileList
If ThisWorkbook.Name = f Then GoTo Nextf
cr = cr + 1
'Do your thing from here to Nextf.
Set slaveWB = Workbooks.Open(pFolder & f)

'Add the data from slave to master.
For Each ws In slaveWB.Worksheets
cs.Range("A" & cr).Value = cr - 1
cs.Range("B" & cr).Value = ws.Name
lr = ws.Range("A1").End(xlDown).Row
For i = LBound(slaveCols) To UBound(slaveCols)
cs.Range(masterCols(i) & cr).Value = ws.Range(slaveCols(i) & lr).Value
cs.Range(masterCols(i) & cr).NumberFormat = ws.Range(slaveCols(i) & lr).NumberFormat
Next i
Next ws
slaveWB.Close False
Nextf:
Next f

'Autofit the columns.
cs.UsedRange.Columns.AutoFit

TheEnd:
SpeedOff
End Sub

Function GetFileList(FileSpec As String) As Variant
' Returns an array of filenames that match FileSpec
' If no matching files are found, it returns False

Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String

On Error GoTo NoFilesFound

FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound

' Loop until no more matching files are found
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
FileName = Dir()
Loop
GetFileList = FileArray
Exit Function

' Error handler
NoFilesFound:
GetFileList = False
End Function
[/VBA]

Thanks Mr. Ken,

This is working fine, but it extract the data of just last worksheet, not all the worksheet.

Actually, it processes all the worksheets and overwrites each. It just needs the cr line moved.

[VBA]Sub GetMyData()
Dim pFolder As String, fileList As Variant, f As Variant
Dim cr As Long, cs As Worksheet, ws As Worksheet
Dim slaveWB As Workbook, slaveCols() As Variant, masterCols() As Variant
Dim i As Integer, lr As Long

On Error GoTo TheEnd
SpeedOn

'Set the parent folder of slave workbooks to process.
pFolder = ThisWorkbook.Path & "\" '<-------- Change as needed.

' Set the column names for the slave and master workbooks with 1-1 match.
' Both arrays must have the same number of elements.
masterCols() = Array("C", "D", "E", "F", "G", "H")
slaveCols() = Array("B", "C", "D", "E", "F", "G")

'Add a new sheet and name it with today's date:
Set cs = Worksheets.Add(After:=Worksheets(Worksheets.Count), Count:=1)
cs.Name = Format(Date, "dd-MMM-yy")

' Add header:
Range("A1").Value = "Sr. No."
Range("B1").Value = "Scrip Code"
Range("C1").Value = "Open"
Range("D1").Value = "High"
Range("E1").Value = "Low"
Range("F1").Value = "Close"
Range("G1").Value = "Volume"
Range("H1").Value = "RSI"
Range("A1:H1").HorizontalAlignment = xlCenter
Range("A1:H1").Font.Bold = True
Range("A2").Select
ActiveWindow.FreezePanes = True

' Open each workbook except thisworkbook and get the data.
cr = 1
fileList = GetFileList(pFolder & "*.xl*")
For Each f In fileList
If ThisWorkbook.Name = f Then GoTo Nextf

'Do your thing from here to Nextf.
Set slaveWB = Workbooks.Open(pFolder & f)

'Add the data from slave to master.
For Each ws In slaveWB.Worksheets
cr = cr + 1
cs.Range("A" & cr).Value = cr - 1
cs.Range("B" & cr).Value = ws.Name
lr = ws.Range("A1").End(xlDown).Row
For i = LBound(slaveCols) To UBound(slaveCols)
cs.Range(masterCols(i) & cr).Value = ws.Range(slaveCols(i) & lr).Value
cs.Range(masterCols(i) & cr).NumberFormat = ws.Range(slaveCols(i) & lr).NumberFormat
Next i
Next ws
slaveWB.Close False
Nextf:
Next f

'Autofit the columns.
cs.UsedRange.Columns.AutoFit

TheEnd:
SpeedOff
End Sub[/VBA]

Hats Off Sir,

Its working absolutely fine. You owe me a big time.

But this report can be run only if I get solution to my previous thread http://www.vbaexpress.com/forum/show...t=38267&page=2

Both are inter-related. I want to use Final Summary to update above thread and then this thread as output.

See if you could help me.

Thank You All for your effort & time.