Modify a Macro - Copy Tab Name and Add To Column A

[ScottMsp]

Hello,

I have a macro that I want to modify and can't quite figure out. What I
want to do is I have many tabs within one workbook. The macro I have copies
and pastes certain pieces of information based on my selection. What I want
to add is the Tab name that the macro is copying from and insert it in column
A.

So for instance, if I had two sheets one titled "A" and one titled "B" and
this macro takes certain rows from each sheet and combines them into one
worksheet based on what I select, I want it to also insert the tab name that
the information came from.

Below is the macro.

Thanks for your help.

Sub CreateLinkedSummary2()
Dim SNames() As String
Dim myAdd As String
Dim myRange As Range
Dim mySS As Worksheet
Dim i As Integer
Dim SCnt As Integer
Dim myCol As Integer

SCnt = ActiveWindow.SelectedSheets.Count

If SCnt = 1 Then
If MsgBox("Are you sure - only one sheet?", vbYesNo) _
= vbYes Then
GoTo ShtOK
Else
MsgBox "Select the sheets and re-run the macro."
Exit Sub
End If
End If

ShtOK:

ReDim SNames(1 To SCnt)

For i = 1 To SCnt
SNames(i) = ActiveWindow.SelectedSheets(i).Name
Next i

Set myRange = Application.InputBox( _
"Select Range to link from", Type:=8)
myAdd = myRange.Address

Set myRange = Application.InputBox( _
"Select sheet and range to link to.", Type:=8)

Set mySS = myRange.Parent
myCol = myRange(1).Column
Worksheets(SNames(1)).Range(myAdd).Copy
mySS.Select
myRange.Select
mySS.Paste Link:=True

For i = 2 To SCnt
Worksheets(SNames(i)).Range(myAdd).Copy
mySS.Cells(mySS.Rows.Count, myCol).End(xlUp)(2).Select
mySS.Paste Link:=True
Next i

myRange.Select
Application.CutCopyMode = False
End Sub

 

[Joel]

I commented out a few line that I think aren't needed and made one chage.
then added the features you wanted.

Sub CreateLinkedSummary2()
Dim SNames() As String
Dim myAdd As String
Dim myRange As Range
Dim mySS As Worksheet
Dim i As Integer
Dim SCnt As Integer
Dim myCol As Integer

SCnt = ActiveWindow.SelectedSheets.Count

If SCnt = 1 Then
If MsgBox("Are you sure - only one sheet?", vbYesNo) _
= vbYes Then
GoTo ShtOK
Else
MsgBox "Select the sheets and re-run the macro."
Exit Sub
End If
End If

ShtOK:

ReDim SNames(1 To SCnt)

For i = 1 To SCnt
SNames(i) = ActiveWindow.SelectedSheets(i).Name
Next i

Set myRange = Application.InputBox( _
"Select Range to link from", Type:=8)
myAdd = myRange.Address

Set myRange = Application.InputBox( _
"Select sheet and range to link to.", Type:=8)

''''Set mySS = myRange.Parent
myCol = myRange(1).Column
Worksheets(SNames(1)).Range(myAdd).Copy
'''''mySS.Select
'''''myRange.Select
''''from mySS.Paste Link:=True
myRange.Paste Link:=True

For i = 2 To SCnt
Worksheets(SNames(i)).Range(myAdd).Copy
LastRow = mySS.Cells(mySS.Rows.Count, myCol).End(xlUp)
NewRow = LastRow + 1
mySS.Cells(NewRow, myCol).Paste Link:=True
LastRow = mySS.Cells(mySS.Rows.Count, myCol).End(xlUp)
mySS.range("A" & NewRow & ":A" & LastRow) = SNames(i)
Next i

myRange.Select
Application.CutCopyMode = False
End Sub