Summarizing data from multiple (1000s) of workbooks into one wrksh

[Steve E]

Working with XL2003

I am trying to write a workbook_open event that will summarize data found in
9 different cells in 1000's of workbooks with identical structure. I'd like
the data to summarize into a single worksheet with 10 columns (first column
to be the file name of the workbook being summarized).

All of these workbooks reside in a single directory on our server (ex
"L:\\Quotes\") but the summary workbook will be in a different directory (ex
"M:\\Monthly Summary Report Data\" )

My Summary report structure looks like:

ColA = summarized workbook file name "fname"
ColB = fname'Quote Form'!$D$4 'Dealer Name
ColC = fname'Quote Form'!$J$2 'Project Name
ColD = fname'Quote Form'!$J$11 'sales Rep ID
ColE = fname'Quote Form'!$D$1 'Date & time file last_changed
ColF = fname'Bill of Materials'!$V$312 'USD Quote Value
ColG = fname'Bill of Materials'!$V$311 'CDN Quote Value
ColH = fname'Bill of Materials'!$V$307 'commission included as %
ColI = fname'Bill of Materials'!$V$309 'Company Gross Margin_(calculated)
ColJ = fname'Quote Form'!$D$20 'Product Group
ColK = fname'Quote Form'!$D$21 'Quote composition


These cell references all contain values derived via formulaes, I only want
to copy the value (not the formula) into my summary -- I definitely do not
want to alter in any way the original data and I don't want links to that
original data.

All of the workbooks (and the worksheets) that are being summarized are
protected with a common set of passwords (PWORD_Workbook and PWORD_Worksheet)
and are emailed to our '(e-mail address removed)' email account by hundreds of
users around the country automatically whenever they save a quote done using
our quotation.xls application (Thanks to Ron De Bruin's CBO emailing code!
and all of the help I've gotten here from others that I collectively refer to
as my "Excellent Helpers")

Each time I open the summary workbook, I want it to update itself with all
of the new records rec'd since my last summary.

I've been muddling around with code from Ron's site but just don't have
enough VBA experience to figure this out. Will anyone here help?

Many thanks in advance,

Steve E

 

[Ron de Bruin]

Try this Steve

http://www.rondebruin.nl/summary2.htm

 

[Steve E]

Ron,

Thanks. I've been trying to work with the code from your FSO_Example_1 that
I found via the usergroup but am having a lot of trouble figuring out how to
adapt it for the 10 cell ranges that I am looking for...

This is realistically over my head but everyone at work thinks that this
should be a snap compared to the quote application (which, with the exception
of the code borrowed from you and a few others is all formula functions that
are a snap for me)... so now I have to "fake it till I make it" as they say.

Regards,

SE

 

[Steve E]

Ron,

I've made some progress after righting a macro that I ran so that the data I
am looking to summarize is now all in a contiguous range so I just use your
code basically as is... now... you have a line of code that clears the
destination worksheet... how do I change that to leave the first row (my
headers) alone and not change the column formatting?

Does this make sense...

What I'd really like to be able to do is not clear the summary but instead
just add the new data to the bottom (of course without duplicating...)

Best regards,

Steve E

 

[Ron de Bruin]

Test Example 2 on that page

 

[Steve E]

Ron,

I tried that one originally but it seems that it only works when I have all
of the workbooks open and there isn't any way for me to do that...

Thanks for your help.

Steve E

 

[Ron de Bruin]

Hi Steve

Note : the code on this moment is only working for cells on one sheet.
First make it work for a few cells on a sheet named "Sheet1"

Insert the code below in a new workbook
If you use the exact macro from my site together with the function
you will see the formula links in Sheet2 to all the files you selected.

Sub Summary_cells_from_Different_Workbooks_2()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range, fndFileName As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "Sheet1" '<---- Change
Set Rng = Range("A1,D5:E5,Z10") '<---- Change

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xls", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Use this sheet for the Summary
Set SummWks = Sheets("Sheet2") '<---- Change

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = LastRow(SummWks) + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'If the workbook name already exist in the sheet the row color will be Blue
Set fndFileName = Nothing
Set fndFileName = SummWks.Cells.Find(JustFileName)
If Not fndFileName Is Nothing Then
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1).Interior.Color = vbBlue
Else
'Do nothing
End If

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
If Err.Number <> 0 Then
'If the sheet name not exist in the workbook the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1).Interior.Color = vbYellow
Else
'Insert the formulas
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = "=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit for setting the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function