Create a summary worksheet from different workbooks (formulas created with VBA macro)

Note : Copy the code in a Standard module of your workbook, working in Mac Excel 2016 and higher.

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 in the browse dialog. Note: in this example you can only select xls, xlsx and xlsm files, but you can add or remove extensions in the applescript string if you want. 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 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.

Tip: if you select the first file in the dialog and hold the shift key down and select the last file all files in between are also selected.

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


Sub Summary_cells_from_Different_Workbooks_Mac()
'Ron de Bruin, 16-Dec-2020
'Select the files you want in folder you select
'links are created to the cells in this workbooks
'https://macexcel.com/examples/filesandfolders/summaryworksheet/
Dim ShName As String
Dim Rng As Range
Dim FileFormat As String
Dim MyPath As String
Dim MyScript As String
Dim MyFiles As String
Dim SummWks As Worksheet
Dim RwNum As Long
Dim FileNameXls As Variant
Dim FNum As Long
Dim ColNum As Long
Dim FinalSlash As Long
Dim JustFileName As String
Dim JustFolder As String
Dim PathStr As String
Dim SheetCheck As String
Dim myCell As Range

' Sheet name and cells in each workbook that you select.
' It will make a link to each cell in Rng (4 cells in this example)
ShName = "Sheet1" '<---- Change
Set Rng = Range("A1,D5:E5,Z10") '<---- Change

'In this example you can only select xls, xlsx and xlsm files
'See my webpage how to use other and more formats.
FileFormat = "{""com.microsoft.excel.xls"",""org.openxmlformats.spreadsheetml.sheet""" & _
",""org.openxmlformats.spreadsheetml.sheet.macroenabled""}"

On Error Resume Next
MyPath = MacScript("return (path to desktop folder) as String")

'Script for Excel 2016 or higher
MyScript = _
"set theFiles to (choose file of type" & _
" " & FileFormat & " " & _
"with prompt ""Please select a file or files"" default location alias """ & _
MyPath & """ with multiple selections allowed)" & vbNewLine & _
"set thePOSIXFiles to {}" & vbNewLine & _
"repeat with aFile in theFiles" & vbNewLine & _
"set end of thePOSIXFiles to POSIX path of aFile" & vbNewLine & _
"end repeat" & vbNewLine & _
"set {TID, text item delimiters} to {text item delimiters, ASCII character 10}" & vbNewLine & _
"set thePOSIXFiles to thePOSIXFiles as text" & vbNewLine & _
"set text item delimiters to TID" & vbNewLine & _
"return thePOSIXFiles"

MyFiles = MacScript(MyScript)
On Error GoTo 0

If MyFiles <> "" Then

With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

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

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

FileNameXls = Split(MyFiles, Chr(10))

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), Application.PathSeparator)
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1) & Application.PathSeparator

'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

'If you want you can use the code lines below to make values of the formulas
'With SummWks.UsedRange
'.Value = .Value
'End With

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

Application.Calculate
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 in the browse dialog. Note: in this example you can only select xls, xlsx and xlsm files, but you can add or remove extensions in the applescript string if you want. 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 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

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 green 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 that you find below the macro.


Sub Summary_cells_from_Different_Workbooks_Mac_2()
'Ron de Bruin, 16-Dec-2020
'Select the files you want in folder you select
'links are created to the cells in this workbooks
'in an existing sheet in the workbook with this macro.
'https://macexcel.com/examples/filesandfolders/summaryworksheet/
Dim ShName As String
Dim Rng As Range
Dim SummWks As Worksheet
Dim FileFormat As String
Dim MyPath As String
Dim MyScript As String
Dim MyFiles As String
Dim FileNameXls As Variant
Dim FNum As Long
Dim ColNum As Long
Dim RwNum As Long
Dim FinalSlash As Long
Dim JustFileName As String
Dim JustFolder As String
Dim fndFileName As Range
Dim PathStr As String
Dim SheetCheck As String
Dim myCell As Range

' Sheet name and cells in each workbook that you select.
' It will make a link to each cell in Rng (4 cells in this example)
ShName = "Sheet1" '<---- Change
Set Rng = Range("A1,D5:E5,Z10") '<---- Change

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

'In this example you can only select xls, xlsx and xlsm files
'See my webpage how to use other and more formats.
FileFormat = "{""com.microsoft.excel.xls"",""org.openxmlformats.spreadsheetml.sheet""" & _
",""org.openxmlformats.spreadsheetml.sheet.macroenabled""}"

On Error Resume Next
MyPath = MacScript("return (path to desktop folder) as String")

'Excel 2016 or higher
MyScript = _
"set theFiles to (choose file of type" & _
" " & FileFormat & " " & _
"with prompt ""Please select a file or files"" default location alias """ & _
MyPath & """ with multiple selections allowed)" & vbNewLine & _
"set thePOSIXFiles to {}" & vbNewLine & _
"repeat with aFile in theFiles" & vbNewLine & _
"set end of thePOSIXFiles to POSIX path of aFile" & vbNewLine & _
"end repeat" & vbNewLine & _
"set {TID, text item delimiters} to {text item delimiters, ASCII character 10}" & vbNewLine & _
"set thePOSIXFiles to thePOSIXFiles as text" & vbNewLine & _
"set text item delimiters to TID" & vbNewLine & _
"return thePOSIXFiles"

MyFiles = MacScript(MyScript)
On Error GoTo 0

If MyFiles <> "" Then

With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

FileNameXls = Split(MyFiles, Chr(10))
For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = LastRow(SummWks) + 1
FinalSlash = InStrRev(FileNameXls(FNum), Application.PathSeparator)
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1) & Application.PathSeparator

'If the workbook name already exist the row color will be Green
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 = vbGreen
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 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

'If you want you can use the code lines below to make values of the formulas
'With SummWks.UsedRange
'.Value = .Value
'End With

' Use AutoFit to set the column width
SummWks.UsedRange.Columns.AutoFit

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

Application.Calculate
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
11-May-2021
Web design by Will Woodgate