Put Sheet name in cell
 

Hello. I have the following code that loops through all sheets in a
workbook, and copies and pastes specific rows if the contents in column B of
the many sheets match the value in A1 of the consolidation sheet.
My question is this, As it copies and pastes a row from a data sheet into
the consolidation sheet, can it also put into column E the data sheet name
where that row came from? Thanks!

Sub CreateTimesheets()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim rng As Range
Dim rw As Long
Dim ws As Worksheet
rw = ActiveSheet.Range("a65536").End(xlUp).Row + 1

For Each ws In Worksheets
With ws
If .Name < "Summary" And .Name < "Summary (2)" _
And .Name < "Sup Summary" And .Name < "Summary by DM" _
And .Name < "Sheet4" Then

Set rng = ws.Range("B3:B" & ws.Range("B65536").End(xlUp).Row)

For Each cell In rng
If cell.Value = ActiveSheet.Range("A1") Then
cell.EntireRow.Copy Destination:=ActiveSheet _
.Cells(rw, 1)
rw = rw + 1
End If
Next
End If
End With
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Put Sheet name in cell
 

steph,

at the bottom of your code you could try;

For Each cell In rng
If cell.Value = ActiveSheet.Range("A1")

cell.EntireRow.Copy Destination:=ActiveSheet _
.Cells(rw, 1)
Activesheet.Cells(rw, 5).Value = ws.name
rw = rw + 1
End If
Next

On Wed, 16 Feb 2005 23:04:27 -0500, "Steph"
wrote:

Hello. I have the following code that loops through all sheets in a
workbook, and copies and pastes specific rows if the contents in column B of
the many sheets match the value in A1 of the consolidation sheet.
My question is this, As it copies and pastes a row from a data sheet into
the consolidation sheet, can it also put into column E the data sheet name
where that row came from? Thanks!

Sub CreateTimesheets()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim rng As Range
Dim rw As Long
Dim ws As Worksheet
rw = ActiveSheet.Range("a65536").End(xlUp).Row + 1

For Each ws In Worksheets
With ws
If .Name < "Summary" And .Name < "Summary (2)" _
And .Name < "Sup Summary" And .Name < "Summary by DM" _
And .Name < "Sheet4" Then

Set rng = ws.Range("B3:B" & ws.Range("B65536").End(xlUp).Row)

For Each cell In rng
If cell.Value = ActiveSheet.Range("A1") Then
cell.EntireRow.Copy Destination:=ActiveSheet _
.Cells(rw, 1)
rw = rw + 1
End If
Next
End If
End With
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Put Sheet name in cell
 

Steph

A couple of suggestions.

Line
If .Name < "Summary" And .Name < "Summary (2)" _
And .Name < "Sup Summary" And .Name < "Summary by
DM" _
And .Name < "Sheet4" Then
should probably have "Or" rather than "and" in the whole
line.... You can't have the name equal to all of those
at the same time

On your question try adding

.Cells(rw,18).value = ws.name

Just before the rw = rw + 1

I don't quite understand what you're trying to do with
the copy..... But maybe this will get you started

Tom D

-----Original Message-----
Hello. I have the following code that loops through all
sheets in a
workbook, and copies and pastes specific rows if the
contents in column B of
the many sheets match the value in A1 of the
consolidation sheet.
My question is this, As it copies and pastes a row from
a data sheet into
the consolidation sheet, can it also put into column E
the data sheet name
where that row came from? Thanks!

Sub CreateTimesheets()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim rng As Range
Dim rw As Long
Dim ws As Worksheet
rw = ActiveSheet.Range("a65536").End(xlUp).Row + 1

For Each ws In Worksheets
With ws
If .Name < "Summary" And .Name < "Summary (2)" _
And .Name < "Sup Summary" And .Name < "Summary by
DM" _
And .Name < "Sheet4" Then

Set rng = ws.Range("B3:B" & ws.Range("B65536").End
(xlUp).Row)

For Each cell In rng
If cell.Value = ActiveSheet.Range("A1") Then
cell.EntireRow.Copy Destination:=ActiveSheet
_
.Cells(rw, 1)
rw = rw + 1
End If
Next
End If
End With
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub


.