Need help with a macro

[enjoylife_95135]

Hi,
I'd like to write a macro that does the following:

' For each worksheet in the workbook, do the following:
' Get the number of rows
' From A1 to the Last row, find the cells with the word "TOTAL" in
them.
' Print the row that the cell belongs to on the active sheet, and
continue doing so for all rows that you find.

So far, I have the following, but it doesn't work
Sub MySub()
Dim ws As Worksheet
Dim lCount As Long
Dim rFoundCell As Range
Dim MyLastCell As Range
For Each ws In ActiveWorkbook.Worksheets
MsgBox ws.Name
Set MyLastCell = LastCell(ws)
Set rFoundCell = Range("A1")
For lCount = 1 To MyLastCell.Row
Set rFoundCell = Columns(1).Find(What:="TOTAL",
After:=rFoundCell, _
LookIn:=xlValues, LookAt:=xlPart,
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=True)
Worksheets(ws).rFoundCell.Copy
ActiveSheet.Paste
Destination:=Worksheets("Sheet1").Range("D15")
' MsgBox rFoundCell.Row


Next lCount
Next
End Sub

 

[enjoylife_95135]

oops, here is Function LastCell. I've grabbed all this code from
various corners of the Internet and I'm having problems making them
work.

Function LastCell(ws As Worksheet) As Range
Dim LastRow&, LastCol%

' Error-handling is here in case there is not any
' data in the worksheet

On Error Resume Next

With ws

' Find the last real row

LastRow& = .Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows).Row

' Find the last real column

LastCol% = .Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByColumns).Column

End With

' Finally, initialize a Range object variable for
' the last populated row.

Set LastCell = ws.Cells(LastRow&, LastCol%)

End Function

 

[Christian]

Hi

Not quite sure if you want to copy the entire row or just the address
or the row number.
Anyway the following will copy the entire row from all sheets when the
word TOTAL apears
in col1 to sheet1 in sequential order.
Hope this is of any help.

Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim rFoundCell As Range
Dim lCount As Long
q = 1
For Each ws In ActiveWorkbook.Worksheets
MsgBox ws.Name
Worksheets(ws.Name).Select
MyLastCell = Application.CountIf(Worksheets(ws.Name).Columns(1),
"TOTAL")
For lCount = 1 To MyLastCell
With Worksheets(ws.Name).Columns(1)
Set rFoundCell = .Find(what:="TOTAL")
If rFoundCell = "TOTAL" Then
rFoundCell.EntireRow.Copy
ActiveSheet.Paste
Destination:=Worksheets("Sheet1").Cells(q, 1)
End If
End With
q = q + 1
Next lCount
Next
End Sub


Cheers Christian