VB Code to search,copy,paste and stop at blank row!

[Anthony]

Hi,

I have a worksheet of data.
I would like some code that will search down column F for 'RBK' when found
copy cells C:J of the next row, paste this into next avaiable row in column
Z. Then copy next rows cells C:J and paste again into next available row in
row Z - keep doing this until there is a blank cell in column F
eg
the data below is a sample, the RBK is found in cell F4, so as a result the
following 3 lines of data should be copy/pasted to next available row in
column Z.
the 4th,5th and 6th are NOT copies as there is a gap (or empty row) between
the sets of data.
..............................RBK
619994 Johnson 04J08G 4DK A5 4:45 13:15
777264 Kaleem 04J08G 1FJ A5 4:45 13:15
704825 Afshan 04J08G 4DK A5 4:45 13:15

701636 Young 04J08G 4FJ A5 4:45 13:15
811513 Carver 06A08G 4DK A5 6:00 14:30
681142 Crowther 06A08G SPA A5 6:00 14:30


...Hope this makes sense and thanks in advance for your help

 

[Jay]

Hi Anthony -

This code operates on the activesheet and is ready to run assuming the
specifications in your original post have not changed ("RBK", Col F, etc).
It permits multiple instances of RBK in the search column. Modify if
necessary and let me know if you have any problems.

Option Base 1
Sub Anthony()

Dim ws As Worksheet
Dim lz, searchRng, rbkCell, img() As Range

Set ws = ActiveSheet
Set lz = ActiveCell
Set searchRng = ws.Columns("F")
sSearchCriterion = "RBK"

While Not searchRng.Find(sSearchCriterion, LookIn:=xlValues,
lookat:=xlPart) Is Nothing

Set rbkCell = searchRng.Find(sSearchCriterion, LookIn:=xlValues,
lookat:=xlPart)
If rbkCell Is Nothing Then MsgBox sSearch & " string not found.":
Exit Sub

Set block = Range(rbkCell, rbkCell.End(xlDown))

If Not block.Find(Null) Is Nothing Then
MsgBox "Anomaly found; empty cell follows RBK... Examine or fix
data and rerun this procedure."
block.Find(Null).Select
Exit Sub
End If

icount = icount + 1
Set block = block.Offset(1, 0).Resize(block.Rows.Count - 1, 1)
ReDim Preserve img(1 To icount)
Set img(icount) = Range(Cells(block.Row, block.Column - 3), _
Cells(block.Row + block.Rows.Count - 1,
block.Column + 4))

Set searchRng = Range(Cells(block.Row, searchRng.Column),
Cells(65536, searchRng.Column))

Wend

For i = 1 To icount
img(i).Copy
Destination:=ActiveSheet.Range("Z65536").End(xlUp).Offset(1, 0)
Next i

lz.Select
End Sub

 

[Jay]

Anthony-

Use this version instead of the one I included earlier. This version has a
slight modification that handles a non-existent "RBK" properly. My apologies
for the double post.
--
Jay
-------
Option Base 1
Sub Anthony()

Dim ws As Worksheet
Dim lz, searchRng, rbkCell, img() As Range

Set ws = ActiveSheet
Set lz = ActiveCell
Set searchRng = ws.Columns("F")
sSearchCriterion = "RBK"
icount = 0

While Not searchRng.Find(sSearchCriterion, LookIn:=xlValues,
lookat:=xlPart) Is Nothing

Set rbkCell = searchRng.Find(sSearchCriterion, LookIn:=xlValues,
lookat:=xlPart)
Set block = Range(rbkCell, rbkCell.End(xlDown))

If Not block.Find(Null) Is Nothing Then
MsgBox "Anomaly found; empty cell follows RBK... Examine or fix
data and rerun this procedure."
block.Find(Null).Select
Exit Sub
End If

icount = icount + 1
Set block = block.Offset(1, 0).Resize(block.Rows.Count - 1, 1)
ReDim Preserve img(1 To icount)
Set img(icount) = Range(Cells(block.Row, block.Column - 3), _
Cells(block.Row + block.Rows.Count - 1,
block.Column + 4))

Set searchRng = Range(Cells(block.Row, searchRng.Column),
Cells(65536, searchRng.Column))

Wend

For i = 1 To icount
img(i).Copy
Destination:=ActiveSheet.Range("Z65536").End(xlUp).Offset(1, 0)
Next i

If icount < 1 Then MsgBox sSearchCriterion & " string not found."
lz.Select
End Sub

 

[Anthony]

Jay,

Many thanks for your suggestion however I can't get ur code to produce
anything!
My criteria hasn't changed ("RBK" in col F etc) so I don't understand as to
why. I am a bit of a novice with VB code so most of yours is beyond me and I
wouldn't know where to start in looking for errors.
I asked a friend to have a look at this and he suggested using this as a
start :

Sub Macro1()
x = Cells(Rows.Count, 6).End(xlUp).Row
y = Cells(Rows.Count, 26).End(xlUp).Row
c = 1
For a = 3 To x
If Cells(a, 6) = "RBK" Then
For b = 3 To 10
Cells(y + c, b+23) = Cells(a + 1, b)
Next b
c = c+ 1
End If
Next a
End Sub

it works just great, but only copies the first row after "RBK" has been
found in column F, I want it to keep copying row after row until a blank row
is found.
Regret my mate is now away so I can't ask him to alter the code so hence my
post here.
Any other suggestions, and thanks again for your kind help
Anthony

 

[Anthony]

Jay,
Sorry I think we crossed over posts, can you please refer to my previous
post and try and help
many thanks

 

[Tom Ogilvy]

Sub Macro1()
Dim bcopy as Boolean
x = Cells(Rows.Count, 6).End(xlUp).Row
y = Cells(Rows.Count, 26).End(xlUp).Row
c = 1
For a = 3 To x
if cells(a, 6) = "" then bCopy = False
if bCopy then
For b = 3 To 10
Cells(y + c, b+23) = Cells(a + 1, b)
Next b
c = c+ 1
End If
If Cells(a, 6) = "RBK" Then bCopy = True
Next a
End Sub

 

[Anthony]

Tom,
thanks so much - works just great !
many many thanks

 

[Jay]

Anthony and Tom -

Sounds like Tom's code has solved your problem. Disregard the rest of this
post if you've moved on to other things.

Sorry for the dysfunctional code. Not sure why it doesn't work. However,
I've run Tom's version and it drops a record in your scenario as I understand
it. If you have checked your output and Tom's code is returning the records
properly, then I've misinterpreted your data structure and wrote code for the
wrong scenario.

Point is, check your output to ensure that all desired records are being
returned. If so, great! If not, and my interpretation is correct, change the
characters "a + 1" to "a" in Tom's code.

I'm also curious why my code did not work for you. If you or Tom have any
ideas, I'd be interested. Note: use the updated code in my second post....

 

[Tom Ogilvy]

change the

characters "a + 1" to "a" in your code that Tom modified.

I agree that
Cells(y + c, b+23) = Cells(a + 1, b)

should be

Cells(y + c, b+23) = Cells(a , b)

Thanks for noticing that.