Create a summary worksheet from different workbooks (with formulas)
Example 1
This macro will add a new workbook with one worksheet.
It will use one row on that sheet for every workbook that you select with GetOpenFilename.
You can use the Ctrl or Shift key to select more then one file, Or use Ctrl a to select all files.
For each cell in the Range "A1,D5:E5,Z10" in "Sheet1" it will add a link on that row.
It will copy the workbook name in column A and the link to the first cell starts in Column B.
Change the following two lines of code before you run the macro.
Each workbook that is selected with GetOpenFilename should contain a sheet name
and data range that matches your changes.
Note: If the sheet does not exist in a selected workbook, that row will be highlighted in yellow.
ShName = "Sheet1" '<---- Change
Set Rng = Range("A1,D5:E5,Z10") '<---- Change
Note: Remember that Excel 97-2003 have only 256 columns.
Excel 2007 has 16384 columns.
Note: There is a limit of 255 characters in the formula.
move the files/folder if the path is to long
Sub Summary_cells_from_Different_Workbooks_1()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng 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, *.xl*", _
MultiSelect:=True)
If IsArray(FileNameXls) = False 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(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)
'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName
'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'", "''")
PathStr = "'" & JustFolder & "\[" & 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
Example 2
This macro will use an existing worksheet in your workbook (I use "Sheet2" in the example)
It will use one row on that sheet for every workbook that you select with GetOpenFilename.
For each cell in the Range "A1,D5:E5,Z10" in "Sheet1" it will add a link on that row.
It will copy the workbook name in column A and the link to the first cell starts in Column B.
Change the following three lines of code before you run the macro.
Each workbook that is selected with GetOpenFilename should contain a sheet name
and data range that matches your changes and the SummWks must exist in the
destination workbook (workbook with this macro).
ShName = "Sheet1" '<---- Change
Set Rng = Range("A1,D5:E5,Z10") '<---- Change
Set SummWks = Sheets("Sheet2") '<---- Change
Note: Remember that Excel 97-2003 have only 256 columns.
Excel 2007 has 16384 columns.
Note: There is a limit of 255 characters in the formula.
move the files/folder if the path is to long
Every time you run the macro it will add the links below the existing formulas that already on
the worksheet. If the sheet not exist in a selected workbook that row will be highlighted in yellow and
if there are already links to a workbook with that name that row will be highlighted in blue.
Note: This macro use the function LastRow
Sub Summary_cells_from_Different_Workbooks_2() 'This example use the function LastRow 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, *.xl*", _ 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 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 JustFileName = WorksheetFunction.Substitute(JustFileName, "'", "''") 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 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 to set the column width 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