Summary All Worksheets With links

[al007]

Sub Summary_All_Worksheets_With_Formulas()
Dim Sh As Worksheet
Dim Newsh As Worksheet
Dim myCell As Range
Dim ColNum As Integer
Dim RwNum As Long
Dim Basebook As Workbook

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

Set Basebook = ThisWorkbook
Set Newsh = Basebook.Worksheets.Add

On Error Resume Next
Newsh.Name = "Summary-Sheet"
If Err.Number > 0 Then
MsgBox "The Summary sheet already exist in this workbook."
With Application
.DisplayAlerts = False
Newsh.Delete
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
Exit Sub
End If

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

For Each Sh In Basebook.Worksheets
If Sh.Name <> Newsh.Name And Sh.Visible Then
ColNum = 1
RwNum = RwNum + 1

Newsh.Cells(RwNum, 1).Value = Sh.Name
'Copy the sheet name in the A column

For Each myCell In Sh.Range("A1,D5:E5,Z10") '
<----Change the range
ColNum = ColNum + 1
Newsh.Cells(RwNum, ColNum).Formula = _
"='" & Sh.Name & "'!" & myCell.Address(False, False)
Next myCell
End If
Next Sh

Newsh.UsedRange.Columns.AutoFit

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

Could Ron or another guru tell me how I can amend the above code as
follows:

(1) Allow me to select the range I want with a message box - where
should i put the code below??

myRange = Application.InputBox( _
Prompt:="Select cell for Standard data.", Type:=8)

(2) Allow me to select the sheets I want instead of all visible
sheets??

(For Each Sh In ActiveWindow.SelectedSheets)

thxs

 

[Ron de Bruin]

Hi al007

Do you want to copy data from a few sheets or create links to the cells???
Is the range continuous ?

 

[al007]

I want to create links to the cells & range can be continuous or non
continuous.
& as per previous post
(3) Allow me to put the range to be copied in an existing sheet
(instead of a new sheet) with a messge box to enter the first cell
where it would start - as I need to run macro for several times on
different range

thxs

 

[Ron de Bruin]

Hi al007

I look at it after work

 

[Ron de Bruin]

Hi

I don not like the way you want to do this with selecting more then one sheet but OK

Note: Copy also the function in the module

It will use this sheet
Set Destsh = Sheets("Summary-Sheet")

Select the cells you want before you run the macro
Then select the sheets you want and run the macro
Every time you run the macro it will add the links below the last line

Note : not more then 256 cells

Sub Summary_All_Worksheets_With_Formulas_Test()
Dim sh As Worksheet
Dim Destsh As Worksheet
Dim myCell As Range
Dim ColNum As Integer
Dim RwNum As Long
Dim Basebook As Workbook
Dim rngaddr As String

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

Set Basebook = ThisWorkbook
Set Destsh = Sheets("Summary-Sheet")

rngaddr = Selection.Address(False, False)


RwNum = LastRow(Destsh) + 1
'The links to the first sheet will start in the first empty row

For Each sh In ActiveWindow.SelectedSheets
ColNum = 1
RwNum = RwNum + 1

Destsh.Cells(RwNum, 1).Value = sh.Name
'Copy the sheet name in the A column

For Each myCell In sh.Range(rngaddr)
ColNum = ColNum + 1
Destsh.Cells(RwNum, ColNum).Formula = _
"='" & sh.Name & "'!" & myCell.Address(False, False)
Next myCell
Next sh

Destsh.UsedRange.Columns.AutoFit

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
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

 

[al007]

Hi Ron,
Thxs for your prompt reply - but I did not expect all selected row of a
sheet to be summarised in only 1 row in the summary sheet.
I wanted it in individual row
e,if my selected sheets are sheet1 & sheet2 & range being A1:C3
i would expect data as follows:
=Sheet1!A1 =Sheet1!B1 =Sheet1!C1
=Sheet1!A2 =Sheet1!B2 =Sheet1!C2
=Sheet1!A3 =Sheet1!B3 =Sheet1!C3
=Sheet2!A1 =Sheet2!B1 =Sheet2!C1
=Sheet2!A2 =Sheet2!B2 =Sheet2!C2
=Sheet2!A3 =Sheet2!B3 =Sheet2!C3

can you help pls

thxs

 

[Ron de Bruin]

Hi al007

Try this one

Sub Summary_All_Worksheets_With_Formulas_Test()
Dim sh As Worksheet
Dim Destsh As Worksheet
Dim myCell As Range
Dim ColNum As Integer
Dim RwNum As Long
Dim Basebook As Workbook
Dim rngaddr As String
Dim a As Integer

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

Set Basebook = ThisWorkbook
Set Destsh = Sheets("Summary-Sheet")

rngaddr = Selection.Address(False, False)


For Each sh In ActiveWindow.SelectedSheets
For a = 1 To sh.Range(rngaddr).Rows.Count
ColNum = 1
RwNum = LastRow(Destsh) + 1

Destsh.Cells(RwNum, 1).Value = sh.Name
'Copy the sheet name in the A column

For Each myCell In sh.Range(rngaddr).Rows(a).Cells
ColNum = ColNum + 1
Destsh.Cells(RwNum, ColNum).Formula = _
"='" & sh.Name & "'!" & myCell.Address(False, False)
Next myCell
Next a
Next sh

Destsh.UsedRange.Columns.AutoFit

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

 

[al007]

Perfect!! - Thxs a lot
Take care

Hi al007

Try this one

Sub Summary_All_Worksheets_With_Formulas_Test()
Dim sh As Worksheet
Dim Destsh As Worksheet
Dim myCell As Range
Dim ColNum As Integer
Dim RwNum As Long
Dim Basebook As Workbook
Dim rngaddr As String
Dim a As Integer

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

Set Basebook = ThisWorkbook
Set Destsh = Sheets("Summary-Sheet")

rngaddr = Selection.Address(False, False)


For Each sh In ActiveWindow.SelectedSheets
For a = 1 To sh.Range(rngaddr).Rows.Count
ColNum = 1
RwNum = LastRow(Destsh) + 1

Destsh.Cells(RwNum, 1).Value = sh.Name
'Copy the sheet name in the A column

For Each myCell In sh.Range(rngaddr).Rows(a).Cells
ColNum = ColNum + 1
Destsh.Cells(RwNum, ColNum).Formula = _
"='" & sh.Name & "'!" & myCell.Address(False, False)
Next myCell
Next a
Next sh

Destsh.UsedRange.Columns.AutoFit

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