View Single Post
  #7   Report Post  
Posted to microsoft.public.excel.misc
Ron de Bruin Ron de Bruin is offline
external usenet poster
 
Posts: 11,123
Default Compile report from multiple workbooks

Test this one for me

See this line

'Fill in the path\folder where the files are
MyPath = "C:\Users\Ron\test"

You can also use a cell with the folder path if you want

Sub Summary_cells_from_Different_Workbooks_2()
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String

'Name of the sheet and the range address in each workbook
ShName = "Sheet1" '<---- Change
Set Rng = Range("A1,D5:E5,Z10") '<---- Change

'Fill in the path\folder where the files are
MyPath = "C:\Users\Ron\test"

'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

'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

If FNum = 0 Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 2
RwNum = 1

For FNum = LBound(MyFiles) To UBound(MyFiles)
ColNum = 1
RwNum = RwNum + 1

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

'build the formula string
JustFileName = WorksheetFunction.Substitute(MyFiles(FNum), "'", "''")
PathStr = "'" & MyPath & "[" & JustFileName & "]" & ShName & "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
If Err.Number < 0 Then
'If the sheet 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
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 to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

MsgBox "The Summary is ready, save the file if you want to keep it"

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


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Ron de Bruin" wrote in message ...
Hi smonsmo

I will add a macro to the webpage tomorrow that will do that.
Maybe this evening if I have time?

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"smonsmo" wrote in message ...
Thanks, that worked beautifully. I have another question though. I have
folders for each month of the year. Within each folder would be all the jobs
that had been scheduled during the corresponding month. Is it possible to
automatically open all the files in the chosen month without being asked to
choose.

"smonsmo" wrote:

I have a folder (J:\COMPANY NAME\2007 Contracts\JOBS BY MONTH\SEPTEMBER) that
contains all the contracts scheduled for a certain month. What I would like
to be able to do is grab the information found in these cells, c1 (Customer
Name), b34 (Job Lead), w29 (Job Dollar Total) and u3 (Date Job was
Completed). Then compile a report on another workbook. Any help would be
greatly appreciated.