I'm trying to creat a macro which will copy and paste the value of a cell
(say G12 on a series of worksheets) to a newly created sheet "Summary". The
code (so far) is below, but far short of what I want to acheive. Can someone
help me?


Sub GetMyCellValues()
Dim ws As Worksheet
Dim myCell As String
i = 1
myCell = Application.InputBox("Enter Cell Reference")
Sheets.Add
ActiveSheet.Name = "Summary"
For Each ws In Worksheets
Worksheets(ws.Name).Select
'Worksheets(ws.Name).Range("a4").Select
Worksheets(ws.Name).Range(myCell).Copy _
Destination:=Worksheets("Summary").Cells(i, 2)
Worksheets("Summary").Cells(i, 1) = ws.Name
i = i + 1
Next ws
End Sub

One way:

Option Explicit
Sub GetMyCellValues()
Dim RptWks As Worksheet
Dim ws As Worksheet
Dim myCell As Range
Dim i As Long

Set myCell = Nothing
On Error Resume Next
Set myCell = Application.InputBox("Click on the cell to use", _
Type:=8).Cells(1)
On Error GoTo 0

If myCell Is Nothing Then
'user hit cancel
Exit Sub
End If

Application.DisplayAlerts = False
On Error Resume Next
Worksheets("Summary").Delete
On Error GoTo 0
Application.DisplayAlerts = True


Set RptWks = Worksheets.Add
RptWks.Name = "Summary"

i = 1
For Each ws In Worksheets
If ws.Name = RptWks.Name Then
'skip it
Else
ws.Range(myCell.Address).Copy _
Destination:=RptWks.Cells(i, 2)
RptWks.Cells(i, 1).Value = "'" & ws.Name
i = i + 1
End If
Next ws
End Sub

But instead of typing the address, application.inputbox with type:=8 allows you
to click on the cell to use.

If you have formulas, you may want to paste special|values, too:

ws.Range(myCell.Address).Copy _
Destination:=RptWks.Cells(i, 2)

becomes

ws.Range(myCell.Address).Copy
RptWks.Cells(i, 2).pastespecial paste:=xlpastevalues

or
rptwks.cells(i,2).value = ws.range(mycell.address).value

(You may want to worry about the numberformat, too.)

Jim May wrote:

I'm trying to creat a macro which will copy and paste the value of a cell
(say G12 on a series of worksheets) to a newly created sheet "Summary". The
code (so far) is below, but far short of what I want to acheive. Can someone
help me?

Sub GetMyCellValues()
Dim ws As Worksheet
Dim myCell As String
i = 1
myCell = Application.InputBox("Enter Cell Reference")
Sheets.Add
ActiveSheet.Name = "Summary"
For Each ws In Worksheets
Worksheets(ws.Name).Select
'Worksheets(ws.Name).Range("a4").Select
Worksheets(ws.Name).Range(myCell).Copy _
Destination:=Worksheets("Summary").Cells(i, 2)
Worksheets("Summary").Cells(i, 1) = ws.Name
i = i + 1
Next ws
End Sub

--

Dave Peterson

Hi Jim
Here is another example
Im sure that Dave's code works fine.
just trying to show there is many way's to do the same job
Remember u dont have to Select/Activate a Sheet to copy from it
(it slow's your code)
good luck and go for it :-)

Sub Sumary()

Dim myCell As String
Dim ws As Integer

On Error GoTo wsAdd
Sheets("Summary").Select
myCell = Application.InputBox("Cells to copy ?", Type:=8).Address

For ws = 1 To Sheets.Count - 1
Cells(ws, 1) = Sheets(ws).Name
Cells(ws, 2) = Sheets(ws).Range(myCell)
Next

GoTo finish
wsAdd:
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "Summary"
On Error GoTo 0
Resume Next
finish:
End Sub



"Jim May" skrev:

I'm trying to creat a macro which will copy and paste the value of a cell
(say G12 on a series of worksheets) to a newly created sheet "Summary". The
code (so far) is below, but far short of what I want to acheive. Can someone
help me?


Sub GetMyCellValues()
Dim ws As Worksheet
Dim myCell As String
i = 1
myCell = Application.InputBox("Enter Cell Reference")
Sheets.Add
ActiveSheet.Name = "Summary"
For Each ws In Worksheets
Worksheets(ws.Name).Select
'Worksheets(ws.Name).Range("a4").Select
Worksheets(ws.Name).Range(myCell).Copy _
Destination:=Worksheets("Summary").Cells(i, 2)
Worksheets("Summary").Cells(i, 1) = ws.Name
i = i + 1
Next ws
End Sub

Much appreciated Dave,
Will study in detail...
Jim

"Dave Peterson" wrote:

One way:

Option Explicit
Sub GetMyCellValues()
Dim RptWks As Worksheet
Dim ws As Worksheet
Dim myCell As Range
Dim i As Long

Set myCell = Nothing
On Error Resume Next
Set myCell = Application.InputBox("Click on the cell to use", _
Type:=8).Cells(1)
On Error GoTo 0

If myCell Is Nothing Then
'user hit cancel
Exit Sub
End If

Application.DisplayAlerts = False
On Error Resume Next
Worksheets("Summary").Delete
On Error GoTo 0
Application.DisplayAlerts = True


Set RptWks = Worksheets.Add
RptWks.Name = "Summary"

i = 1
For Each ws In Worksheets
If ws.Name = RptWks.Name Then
'skip it
Else
ws.Range(myCell.Address).Copy _
Destination:=RptWks.Cells(i, 2)
RptWks.Cells(i, 1).Value = "'" & ws.Name
i = i + 1
End If
Next ws
End Sub

But instead of typing the address, application.inputbox with type:=8 allows you
to click on the cell to use.

If you have formulas, you may want to paste special|values, too:

ws.Range(myCell.Address).Copy _
Destination:=RptWks.Cells(i, 2)

becomes

ws.Range(myCell.Address).Copy
RptWks.Cells(i, 2).pastespecial paste:=xlpastevalues

or
rptwks.cells(i,2).value = ws.range(mycell.address).value

(You may want to worry about the numberformat, too.)

Jim May wrote:

I'm trying to creat a macro which will copy and paste the value of a cell
(say G12 on a series of worksheets) to a newly created sheet "Summary". The
code (so far) is below, but far short of what I want to acheive. Can someone
help me?

Sub GetMyCellValues()
Dim ws As Worksheet
Dim myCell As String
i = 1
myCell = Application.InputBox("Enter Cell Reference")
Sheets.Add
ActiveSheet.Name = "Summary"
For Each ws In Worksheets
Worksheets(ws.Name).Select
'Worksheets(ws.Name).Range("a4").Select
Worksheets(ws.Name).Range(myCell).Copy _
Destination:=Worksheets("Summary").Cells(i, 2)
Worksheets("Summary").Cells(i, 1) = ws.Name
i = i + 1
Next ws
End Sub

--

Dave Peterson

thanks excelent,
Great code!
Jim

"excelent" wrote:

Hi Jim
Here is another example
Im sure that Dave's code works fine.
just trying to show there is many way's to do the same job
Remember u dont have to Select/Activate a Sheet to copy from it
(it slow's your code)
good luck and go for it :-)

Sub Sumary()

Dim myCell As String
Dim ws As Integer

On Error GoTo wsAdd
Sheets("Summary").Select
myCell = Application.InputBox("Cells to copy ?", Type:=8).Address

For ws = 1 To Sheets.Count - 1
Cells(ws, 1) = Sheets(ws).Name
Cells(ws, 2) = Sheets(ws).Range(myCell)
Next

GoTo finish
wsAdd:
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "Summary"
On Error GoTo 0
Resume Next
finish:
End Sub



"Jim May" skrev:

I'm trying to creat a macro which will copy and paste the value of a cell
(say G12 on a series of worksheets) to a newly created sheet "Summary". The
code (so far) is below, but far short of what I want to acheive. Can someone
help me?


Sub GetMyCellValues()
Dim ws As Worksheet
Dim myCell As String
i = 1
myCell = Application.InputBox("Enter Cell Reference")
Sheets.Add
ActiveSheet.Name = "Summary"
For Each ws In Worksheets
Worksheets(ws.Name).Select
'Worksheets(ws.Name).Range("a4").Select
Worksheets(ws.Name).Range(myCell).Copy _
Destination:=Worksheets("Summary").Cells(i, 2)
Worksheets("Summary").Cells(i, 1) = ws.Name
i = i + 1
Next ws
End Sub