Copy rows from all sheets based on cell value

[Steph]

Hi all. I have a workbook that has 100+ sheets in it. I added a sheet
(sheet1) , and in cell A1 of that sheet is the word "Payment".

I would like to cycle through every sheet, and copy every row that has the
word "payment" in column B into Sheet1, one after the other.

Anyone know how I can do this? Also, I would love to somehow tag each line
with the Sheetname it came from. Possible? Thanks!

 

[Guest]

Give this code a try...

Option Explicit

Private Sub CopyPayments()
Dim rngFound As Range
Dim rngStart As Range
Dim rngPaste As Range
Dim wks As Worksheet

Set rngPaste = Sheet1.Range("A2")

For Each wks In Worksheets
If wks.Name <> Sheet1.Name Then
Set rngFound = wks.Cells.Find("payment", , , xlWhole)
Set rngStart = rngFound

Do
rngFound.EntireRow.Copy rngPaste
Set rngFound = wks.Cells.FindNext(rngFound)
Set rngPaste = rngPaste.Offset(1, 0)
Loop Until rngStart.Address = rngFound.Address
Set rngStart = Nothing
End If
Next wks
End Sub

HTH

 

[Guest]

The previous code assumes that there will be a payment on each sheet. If that
is not the case then try this...

Option Explicit

Private Sub CopyPayments()
Dim rngFound As Range
Dim rngStart As Range
Dim rngPaste As Range
Dim wks As Worksheet

Set rngPaste = Sheet1.Range("A2")

For Each wks In Worksheets
If wks.Name <> Sheet1.Name Then
Set rngFound = wks.Cells.Find("payment", , , xlWhole)
Set rngStart = rngFound
If Not rngFound Is Nothing Then
Do
rngFound.EntireRow.Copy rngPaste
Set rngFound = wks.Cells.FindNext(rngFound)
Set rngPaste = rngPaste.Offset(1, 0)
Loop Until rngStart.Address = rngFound.Address
Set rngStart = Nothing
End If
End If
Next wks
End Sub

HTH