macro for finding & copying

Try this :-

Sub Copy_Paste()
Dim sourceSheet As Worksheet, destSheet As Worksheet
Dim lookFor As String
Dim sourceRange As Range, cell As Range, sourceRow As Range
Dim srws&, sr&
Dim dLastRow&, dLastCol&, dNextRow&

Set sourceSheet = Sheets("Sheet1")
Set destSheet = Sheets("Sheet2")
lookFor = "BR"

Application.ScreenUpdating = False
Set sourceRange = sourceSheet.UsedRange
srws = sourceRange.Rows.Count
For sr = 1 To srws
Set sourceRow = Intersect(sourceRange(sr, 1).EntireRow, sourceRange)
For Each cell In sourceRow
If cell = lookFor Then
cell.EntireRow.Copy
With destSheet
If Application.CountA(.Rows(1)) = 0 Then
ActiveSheet.Paste .Rows(1)
Exit For
Else
dLastRow = .Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows).Row
dLastCol = .Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByColumns).Column
dNextRow = .Cells(dLastRow, dLastCol).Row + 1
ActiveSheet.Paste .Rows(dNextRow)
Exit For
End If
End With
End If
Next cell
Next sr
Application.CutCopyMode = False
End Sub

Hi Julie

Here's another way:

Sub BR()
Dim StopRw As Long

StopRw = Sheets("Sheet1").Range("A65532").End(xlUp).Row
With Sheets("Sheet2")
.Range("A1") = "=IF(Sheet1!A1=""B/R"",Sheet1!A1,NA())"
.Range("A1").AutoFill Destination:=Range("A1:A" & StopRw)
.Columns(1).SpecialCells(xlCellTypeFormulas, xlErrors).Delete
.Columns(1).Copy
.Columns(1).PasteSpecial xlValues
End With
Application.CutCopyMode = False
End Sub

Should run pretty quick.
OzGrid Business Applications

But this macro only works on one column of data and merely tranfers Sheet1 Col A to Sheet2 Col A and clears the contents of cells that don't contain "B/R".
I doubt that this is what was required.
Celia

...And merry Christmas to you too Celia!

Julie is seems I may have misinterpreted you question.

Try this one instead.

Sub TryAgain()
Dim lastRw As Long, i As Long
Dim Found As Integer, NewRw As Long
Application.ScreenUpdating = False
With Sheets("Sheet1")
lastRw = .Cells.Find(What:="*", After:=.Range("A1"), _
LookIn:=xlValues, SearchDirection:=xlPrevious).Row

For i = 1 To lastRw
On Error Resume Next
Found = 0
Found = .Rows(i).Find(What:="B/R", After:=.Range("A" & i), _
LookIn:=xlValues, SearchDirection:=xlNext).EntireRow.Copy
If Found <> 0 Then
NewRw = NewRw + 1
Sheets("Sheet2").Cells(NewRw, 1).PasteSpecial
End If
Next
End With

Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub

OzGrid Business Applications

...And merry Christmas to you too Celia! Julie is seems I may have misinterpreted you question. Try this one instead. Sub TryAgain() Dim lastRw As Long, i As Long Dim Found As Integer, NewRw As Long Application.ScreenUpdating = False With Sheets("Sheet1") lastRw = .Cells.Find(What:="*", After:=.Range("A1"), _ LookIn:=xlValues, SearchDirection:=xlPrevious).Row For i = 1 To lastRw On Error Resume Next Found = 0 Found = .Rows(i).Find(What:="B/R", After:=.Range("A" & i), _ LookIn:=xlValues, SearchDirection:=xlNext).EntireRow.Copy If Found <> 0 Then NewRw = NewRw + 1 Sheets("Sheet2").Cells(NewRw, 1).PasteSpecial End If Next End With Application.ScreenUpdating = True Application.CutCopyMode = False

Julie
Depends what you need - Dave's might not do it.
If Sheet2 is a blank sheet and needs the relevant Sheet1 data entered on a "one-time only" basis, then use either Dave's macro or my macro (I think Dave's should be quicker, but the run-time would probably only be noticeable for a very large number of data rows).
If Sheet2 is to be maintained as a permanent record to which data from time to time is added from a new Sheet1 each time, then either use my macro or an adjusted version of Dave's macro :-

Sub TryTryAgain()
Dim sourceSheet As Worksheet, destSheet As Worksheet
Dim lookFor As String
Dim lastRw As Long, i As Long
Dim Found As Integer, NewRow As Long

Set sourceSheet = Sheets("Sheet1")
Set destSheet = Sheets("Sheet2")
lookFor = "B/R"

Application.ScreenUpdating = False
With sourceSheet
lastRw = .Cells.Find(What:="*", After:=.Range("A1"), _
LookIn:=xlValues, SearchDirection:=xlPrevious).Row
For i = 1 To lastRw
On Error Resume Next
Found = 0
Found = .Rows(i).Find(What:=lookFor, After:=.Range("A" & i), _
LookIn:=xlValues, SearchDirection:=xlNext).EntireRow.Copy
If Found <> 0 Then
With destSheet
If Application.CountA(.Rows(1)) = 0 Then
ActiveSheet.Paste .Rows(1)
Else
NewRow = .Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows).Row + 1
ActiveSheet.Paste .Rows(NewRow)
End If
End With
End If
Next
End With
Application.CutCopyMode = False
End Sub

Celia

I guess the only way for Julie to find out if mine is applicable (which I think it is) is to run it on a copy of the workbook.

Re Time difference:

I tested both codes on 10 000 rows of data
Mine = 00:00:34
Celia = 00:05:46

OzGrid Business Applications

I guess the only way for Julie to find out if mine is applicable (which I think it is) is to run it on a copy of the workbook. Re Time difference: I tested both codes on 10 000 rows of data Mine = 00:00:34 Celia = 00:05:46

Holy kangaroos! Give it a rest, Dave.
I've already pointed out that your macro (if it does what is required - and you cannot assume that it does!) should be quicker if there are a lot of data rows.
The fact remains that my macro covers all possibilities whereas your first one was useless and your second one works under specific cicumstances only.
I hereby withdraw from this discussion while you are still behind.
Celia

Celia

I Can't believe you !!!

Why such a big chip on your shoulder? and such negativity?

From my very first post on this forum you have attacked me. unlike you, I would never pick holes in another person trying to help others. Now you have taken it one step futher and called my code "useless". Just what does that achieve ?

It's not for the people answering questions to nit pick other helpers code. If the helpers code is not applicable the question asker will soon say.

I was fully aware of the time diff before I posted it, as I did a check out of curiousity. The only reason I posted it was due to you constant negativity on my help. I guess I have sunk to your level and for that I'm sorry!

As I said in relpy to your first attack
"...and Merry Xmas to you too"

OzGrid Business Applications

I Can't believe you !!! Why such a big chip on your shoulder? and such negativity? From my very first post on this forum you have attacked me. unlike you, I would never pick holes in another person trying to help others. Now you have taken it one step futher and called my code "useless". Just what does that achieve ? It's not for the people answering questions to nit pick other helpers code. If the helpers code is not applicable the question asker will soon say. I was fully aware of the time diff before I posted it, as I did a check out of curiousity. The only reason I posted it was due to you constant negativity on my help. I guess I have sunk to your level and for that I'm sorry! As I said in relpy to your first attack "...and Merry Xmas to you too"

And the band played on....

Chip on shoulder? Negativity? Attacks on you?
What on Earth are you talking about?
To avoid any more childish arguments publicly I shall reply to you privately regarding your illuminating display of paranoia. (Your first code was useless though...wasn't it!).

Have a nice day!

Celia

PS. The following macro should fit all possibilities. It is basically your second macro (not forgetting to stress, of course, that I fully recognise it is far superior to mine - much quicker you know) with a minor amendment :-

Sub FinalTryAgain()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lookFor As String
Dim lastRw As Long, i As Long
Dim found As Integer, newRw As Long

Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
lookFor = "B/R"

Application.ScreenUpdating = False
With ws2
If Application.CountA(.Rows(1)) = 0 Then
newRw = 0
Else
newRw = .Cells.Find(What:="*", _
After:=.Range("A1"), LookIn:=xlValues, _
SearchDirection:=xlPrevious).Row
End If
End With
With ws1
lastRw = .Cells.Find(What:="*", _
After:=.Range("A1"), LookIn:=xlValues, _
SearchDirection:=xlPrevious).Row
For i = 1 To lastRw
On Error Resume Next
found = 0
found = .Rows(i).Find(What:=lookFor, _
After:=.Range("A" & i), LookIn:=xlValues, _
SearchDirection:=xlNext).EntireRow.Copy
If found <> 0 Then
newRw = newRw + 1
ws2.Cells(newRw, 1).PasteSpecial
End If
Next
End With
Application.CutCopyMode = False
End Sub

And the band played on.... Chip on shoulder? Negativity? Attacks on you? What on Earth are you talking about? To avoid any more childish arguments publicly I shall reply to you privately regarding your illuminating display of paranoia. (Your first code was useless though...wasn't it!). Have a nice day! Celia PS. The following macro should fit all possibilities. It is basically your second macro (not forgetting to stress, of course, that I fully recognise it is far superior to mine - much quicker you know) with a minor amendment :- Sub FinalTryAgain() Dim ws1 As Worksheet, ws2 As Worksheet Dim lastRw As Long, i As Long Dim found As Integer, newRw As Long Set ws1 = Sheets("Sheet1") Set ws2 = Sheets("Sheet2") lookFor = "B/R" Application.ScreenUpdating = False With ws2 newRw = 0 newRw = .Cells.Find(What:="*", _ After:=.Range("A1"), LookIn:=xlValues, _ SearchDirection:=xlPrevious).Row With ws1 lastRw = .Cells.Find(What:="*", _ After:=.Range("A1"), LookIn:=xlValues, _ SearchDirection:=xlPrevious).Row For i = 1 To lastRw On Error Resume Next found = 0 found = .Rows(i).Find(What:=lookFor, _ After:=.Range("A" & i), LookIn:=xlValues, _ SearchDirection:=xlNext).EntireRow.Copy If found <> 0 Then newRw = newRw + 1 ws2.Cells(newRw, 1).PasteSpecial Next

Celia, if you wish to email me then you will need my work address, which is:

dhawley@micl.com.au