Hi
Sorry for the late response (very busy)
Try this example
It will make links to Range("A1:E1")
It use the sheet with the same name as the workbook name
Sub Summary_cells_from_Different_Workbooks()
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
Set Rng = Range("A1:E1") '<---- Change
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xls", _
MultiSelect:=True)
'Select the files with GetOpenFilename
If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Set SummWks = Workbooks.Add(1).Worksheets(1)
'Add a new workbook with one sheet for the Summary
RwNum = 1
'The links to the first sheet will start in row 2
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)
SummWks.Cells(RwNum, 1).Value = JustFileName
'copy the workbook name in column A
ShName = Left(JustFileName, Len(JustFileName) - 4)
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!"
'build the formula string
On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
If Err.Number <> 0 Then
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1).Interior.Color = vbYellow
'If the sheet name not exist in the workbook the row color will be Yellow.
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
SummWks.UsedRange.Columns.AutoFit
' Use AutoFit for setting the column width in the new workbook
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