PDA

View Full Version : Combine Certain Data From All Worksheets in All Workbooks in a Specified Directory



Fimez
04-16-2008, 02:12 PM
Hello there,

I am new to this Forum so I hope I am doing everything correctly, please let me know if I am not. :hi:

I came across the following code listing "Combine All Data From All Worksheets in All Workbooks in a Specified Directory" submitted by mvidas which works fantastically.
I am trying to do a very similar operation but instead of copying "all" data from each sheet in each workbook in a directory, I would like to just extract the information in certain cells on each sheet in each workbook in a directory and place that information in rows in one sheet of a new master workbook.

If anyone knows how I can modify the code below to achieve this it would be much appreciated.

Many thanks in advance.

Fimez



Option Explicit

Sub CombineSheetsFromAllFilesInADirectory()

Dim Path As String 'string variable to hold the path to look through
Dim FileName As String 'temporary filename string variable
Dim tWB As Workbook 'temporary workbook (each in directory)
Dim tWS As Worksheet 'temporary worksheet variable
Dim mWB As Workbook 'master workbook
Dim aWS As Worksheet 'active sheet in master workbook
Dim RowCount As Long 'Rows used on master sheet
Dim uRange As Range 'usedrange for each temporary sheet

'***** Set folder to cycle through *****
Path = ThisWorkbook.Path & "\subdirectory\" 'Change as needed, ie "C:\"

Application.EnableEvents = False 'turn off events
Application.ScreenUpdating = False 'turn off screen updating
Set mWB = Workbooks.Add(1) 'create a new one-worksheet workbook
Set aWS = mWB.ActiveSheet 'set active sheet variable to only sheet in mWB
If Right(Path, 1) <> Application.PathSeparator Then 'if path doesnt end in "\"
Path = Path & Application.PathSeparator 'add "\"
End If
FileName = Dir(Path & "*.xls", vbNormal) 'set first file's name to filename variable
Do Until FileName = "" 'loop until all files have been parsed
If Path <> ThisWorkbook.Path Or FileName <> ThisWorkbook.Name Then
Set tWB = Workbooks.Open(FileName:=Path & FileName) 'open file, set to tWB variable
For Each tWS In tWB.Worksheets 'loop through each sheet
Set uRange = tWS.Range("A2", tWS.Cells(tWS.UsedRange.Row + tWS.UsedRange.Rows _
.Count - 1, tWS.UsedRange.Column + tWS.UsedRange.Columns.Count - 1)) 'set used range
If RowCount + uRange.Rows.Count > 65536 Then 'if the used range wont fit on the sheet
aWS.Columns.AutoFit 'autofit mostly-used worksheet's columns
Set aWS = mWB.Sheets.Add(After:=aWS) 'add a new sheet that will accommodate data
RowCount = 0 'reset RowCount variable
End If
If RowCount = 0 Then 'if working with a new sheet
aWS.Range("A1", aWS.Cells(1, uRange.Columns.Count)).Value = _
tWS.Range("A1", tWS.Cells(1, uRange.Columns.Count)).Value 'copy headers from tWS
RowCount = 1 'add one to rowcount
End If
aWS.Range("A" & RowCount + 1).Resize(uRange.Rows.Count, uRange.Columns.Count).Value _
= uRange.Value 'move data from temp sheet to data sheet
RowCount = RowCount + uRange.Rows.Count 'increase rowcount accordingly
Next 'tWS
tWB.Close False 'close temporary workbook without saving
End If
FileName = Dir() 'set next file's name to FileName variable
Loop
aWS.Columns.AutoFit 'autofit columns on last data sheet
mWB.Sheets(1).Select 'select first data sheet on master workbook
Application.EnableEvents = True 're-enable events
Application.ScreenUpdating = True 'turn screen updating back on

'Clear memory of the object variables
Set tWB = Nothing
Set tWS = Nothing
Set mWB = Nothing
Set aWS = Nothing
Set uRange = Nothing
End Sub

mdmackillop
04-16-2008, 02:17 PM
There are a couple of approaches. Is it the same sheets/cells in all workbooks? How many cells per workbook and how many workbooks (approx figures will do)

Fimez
04-16-2008, 02:30 PM
There are a couple of approaches. Is it the same sheets/cells in all workbooks? How many cells per workbook and how many workbooks (approx figures will do)
Thanks for the swift reply.

The Workbooks have identical layouts and there are 52 workbooks containing four sheets each in the directory i.e. one for each week of the year.
Information is required from approximately six cells, on two different sheets in each workbook but it is always the same cells.

The information from each workbook needs to go into a single row in the new master workbook.

Hope this helps.

mdmackillop
04-16-2008, 02:35 PM
Have a look at this item (http://vbaexpress.com/kb/getarticle.php?kb_id=454) If you need help modifying it, let us know.

Fimez
04-16-2008, 02:51 PM
Thanks

I will try and combine this code into the previous code as I want the macro to find each workbook in a directory itself as the workbook names are different.
I am not quite sure yet how to specify the particular cells on the particular sheets where the data I require is and do this in a loop, before moving on to the next workbook, but I will persevere.

mdmackillop
04-16-2008, 03:41 PM
Untested

Option Explicit
'you can extract data from a closed file by using an
'XLM macro. Credit for this technique goes to John
'Walkenback > http://j-walk.com/ss/excel/tips/tip82.htm
Sub GetDataDemo()
Dim FilePath$, Row&, Column&, Address$
Dim WS As Worksheet
Dim SourceSheet, SourceCell, sh, cel
Dim MyFile As String
Dim Tgt As Range
Dim i As Long

'change constants & FilePath below to suit
'***************************************
FilePath = "C:\AAA\"
'***************************************
SourceSheet = Array("Sheet1", "Sheet2")
SourceCell = Array("A1", "B2", "C3", "D4", "E5", "F6")
Set WS = ActiveWorkbook.Sheets(1)
DoEvents
Application.ScreenUpdating = False
MyFile = Dir(FilePath & "*.xls")
Do Until MyFile = ""
With WS
Set Tgt = .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
End With
i = 0
For Each sh In SourceSheet
For Each cel In SourceCell
Tgt.Offset(, i) = GetData(FilePath, MyFile, sh, cel)
i = i+1
Next
Next sh
MyFile = Dir
Loop

End Sub


Private Function GetData(Path, File, Sheet, Address)
Dim Data$
Data = "'" & Path & "[" & File & "]" & Sheet & "'!" & _
Range(Address).Range("A1").Address(, , xlR1C1)
GetData = ExecuteExcel4Macro(Data)
End Function

Fimez
04-16-2008, 04:22 PM
I tried this code, thanks, but the only problem I am finding now is that it returns #Ref in the new Worksheet, I have tried it with a dummy workbook with just raw data values in it and things work fine.

When I check the other original workbooks the cells just seem to contain Raw data i.e. No Formulas so I can't understand why there is a problem?

Any Ideas?


Option Explicit
'you can extract data from a closed file by using an
'XLM macro. Credit for this technique goes to John
'Walkenback >
Sub GetDataDemo()
Dim FilePath$, Row&, Column&, Address$
Dim WS As Worksheet
Dim SourceSheet, SourceCell, sh, cel
Dim MyFile As String
Dim Tgt As Range
Dim i As Long

'change constants & FilePath below to suit
'***************************************
FilePath = "C:\AAA\"
'***************************************
SourceSheet = Array("Sheet1", "Sheet2")
SourceCell = Array("A1", "B2", "C3", "D4", "E5", "F6")
Set WS = ActiveWorkbook.Sheets(1)
DoEvents
Application.ScreenUpdating = False
MyFile = Dir(FilePath & "*.xls")
Do Until MyFile = ""
With WS
Set Tgt = .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
End With
i = 0
For Each sh In SourceSheet
For Each cel In SourceCell
Tgt.Offset(, i) = GetData(FilePath, MyFile, sh, cel)
i = i+1
Next
Next sh
MyFile = Dir
Loop

End Sub


Private Function GetData(Path, File, Sheet, Address)
Dim Data$
Data = "'" & Path & "[" & File & "]" & Sheet & "'!" & _
Range(Address).Range("A1").Address(, , xlR1C1)
GetData = ExecuteExcel4Macro(Data)
End Function


[/vba][/quote]