VB Code to search,copy,paste and stop at blank row!
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 |
VB Code to search,copy,paste and stop at blank row!
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" wrote: 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 |
VB Code to search,copy,paste and stop at blank row!
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" wrote: 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 |
VB Code to search,copy,paste and stop at blank row!
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 "Jay" wrote: 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" wrote: 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 |
VB Code to search,copy,paste and stop at blank row!
Jay,
Sorry I think we crossed over posts, can you please refer to my previous post and try and help many thanks "Jay" wrote: 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" wrote: 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 |
VB Code to search,copy,paste and stop at blank row!
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 -- regards Tom Ogilvy "Anthony" wrote: 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 "Jay" wrote: 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" wrote: 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 |
VB Code to search,copy,paste and stop at blank row!
Tom,
thanks so much - works just great ! many many thanks "Tom Ogilvy" wrote: 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 -- regards Tom Ogilvy "Anthony" wrote: 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 "Jay" wrote: 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" wrote: 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 |
VB Code to search,copy,paste and stop at blank row!
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.... -- Thanks, Jay "Anthony" wrote: Tom, thanks so much - works just great ! many many thanks "Tom Ogilvy" wrote: 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 -- regards Tom Ogilvy "Anthony" wrote: 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 "Jay" wrote: 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" wrote: 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 |
VB Code to search,copy,paste and stop at blank row!
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. -- Regards, Tom Ogilvy "Jay" wrote in message ... 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.... -- Thanks, Jay "Anthony" wrote: Tom, thanks so much - works just great ! many many thanks "Tom Ogilvy" wrote: 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 -- regards Tom Ogilvy "Anthony" wrote: 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 "Jay" wrote: 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" wrote: 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 |
All times are GMT +1. The time now is 03:12 PM. |
Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
ExcelBanter.com