|
A real cut and paste
So far I have looked at many examples and i have tried many ways but I
have yet to figure out how to do a real cut and paste. So far in all my codes I have been able to do a copy and paste and then a delete selction but I can't this time. So hopefully someone can help me out. My code is as follows... With Worksheets(1).Range("A1:A500") Set c = .Find("Substrate # 2", LookIn:=xlValues) If Not c Is Nothing Then firstAddress = c.Address y = 1 Do Range(c.Offset(0, 0), c.Offset(3, 1)).Copy Range(Cells(y, 3), Cells(y, 4)).PasteSpecial Set c = .FindNext(c) y = y + 4 Loop While Not c Is Nothing And c.Address < firstAddress End If End With I want it to cut and paste rather than copy and paste. I have tried taking out the copy replacing it with a cut didn't work then tried setting the ranges and ranges using the Dim function. I need help please. |
A real cut and paste
On Jul 9, 9:44 am, "Don Guillett" wrote:
try Sub cutpaste() On Error GoTo timetoquit With Worksheets("sheet2").Range("A1:A500") Set c = .Find("s", LookIn:=xlValues) If Not c Is Nothing Then firstAddress = c.Address y = 1 Do Range(c.Offset(0, 0), c.Offset(3, 1)).Cut Cells(y, 3) ' Range(c.Offset(0, 0), c.Offset(3, 1)).Copy ' Range(Cells(y, 3), Cells(y, 4)).PasteSpecial Set c = .FindNext(c) y = y + 4 Loop While Not c Is Nothing And c.Address < firstAddress End If End With timetoquit: End Sub -- Don Guillett Microsoft MVP Excel SalesAid Software wrote in message oups.com... So far I have looked at many examples and i have tried many ways but I have yet to figure out how to do a real cut and paste. So far in all my codes I have been able to do a copy and paste and then a delete selction but I can't this time. So hopefully someone can help me out. My code is as follows... With Worksheets(1).Range("A1:A500") Set c = .Find("Substrate # 2", LookIn:=xlValues) If Not c Is Nothing Then firstAddress = c.Address y = 1 Do Range(c.Offset(0, 0), c.Offset(3, 1)).Copy Range(Cells(y, 3), Cells(y, 4)).PasteSpecial Set c = .FindNext(c) y = y + 4 Loop While Not c Is Nothing And c.Address < firstAddress End If End With I want it to cut and paste rather than copy and paste. I have tried taking out the copy replacing it with a cut didn't work then tried setting the ranges and ranges using the Dim function. I need help please.- Hide quoted text - - Show quoted text - that does not work it only cuts and pastes once for each substrate. It doesn't loop the cut and paste. |
A real cut and paste
|
A real cut and paste
Maybe something like this. It isn't clear to me where you actually want to
place the cells you find - so I put them below the data before deleting the rows. Dim c as Range, r as Range, r1 as Range With Worksheets(1).Range("A1:A500") Set c = .Find("Substrate # 2", LookIn:=xlValues) If Not c Is Nothing Then firstAddress = c.Address Do set r = Range(c.Offset(0, 0), c.Offset(3, 1)) if r1 is nothing then set r1 = r else set r1 = union(r1,r) end if Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address < firstAddress if not r1 is nothing then r1.copy cells(rows.count,1).End(xlup).offset(0,4).PasteSpe cial r1.EntireRow.Delete end if End If End With -- Regards, Tom Ogilvy " wrote: On Jul 9, 9:44 am, "Don Guillett" wrote: try Sub cutpaste() On Error GoTo timetoquit With Worksheets("sheet2").Range("A1:A500") Set c = .Find("s", LookIn:=xlValues) If Not c Is Nothing Then firstAddress = c.Address y = 1 Do Range(c.Offset(0, 0), c.Offset(3, 1)).Cut Cells(y, 3) ' Range(c.Offset(0, 0), c.Offset(3, 1)).Copy ' Range(Cells(y, 3), Cells(y, 4)).PasteSpecial Set c = .FindNext(c) y = y + 4 Loop While Not c Is Nothing And c.Address < firstAddress End If End With timetoquit: End Sub -- Don Guillett Microsoft MVP Excel SalesAid Software wrote in message oups.com... So far I have looked at many examples and i have tried many ways but I have yet to figure out how to do a real cut and paste. So far in all my codes I have been able to do a copy and paste and then a delete selction but I can't this time. So hopefully someone can help me out. My code is as follows... With Worksheets(1).Range("A1:A500") Set c = .Find("Substrate # 2", LookIn:=xlValues) If Not c Is Nothing Then firstAddress = c.Address y = 1 Do Range(c.Offset(0, 0), c.Offset(3, 1)).Copy Range(Cells(y, 3), Cells(y, 4)).PasteSpecial Set c = .FindNext(c) y = y + 4 Loop While Not c Is Nothing And c.Address < firstAddress End If End With I want it to cut and paste rather than copy and paste. I have tried taking out the copy replacing it with a cut didn't work then tried setting the ranges and ranges using the Dim function. I need help please.- Hide quoted text - - Show quoted text - that does not work it only cuts and pastes once for each substrate. It doesn't loop the cut and paste. |
A real cut and paste
On Jul 9, 10:20 am, Tom Ogilvy
wrote: Maybe something like this. It isn't clear to me where you actually want to place the cells you find - so I put them below the data before deleting the rows. Dim c as Range, r as Range, r1 as Range With Worksheets(1).Range("A1:A500") Set c = .Find("Substrate # 2", LookIn:=xlValues) If Not c Is Nothing Then firstAddress = c.Address Do set r = Range(c.Offset(0, 0), c.Offset(3, 1)) if r1 is nothing then set r1 = r else set r1 = union(r1,r) end if Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address < firstAddress if not r1 is nothing then r1.copy cells(rows.count,1).End(xlup).offset(0,4).PasteSpe cial r1.EntireRow.Delete end if End If End With -- Regards, Tom Ogilvy " wrote: On Jul 9, 9:44 am, "Don Guillett" wrote: try Sub cutpaste() On Error GoTo timetoquit With Worksheets("sheet2").Range("A1:A500") Set c = .Find("s", LookIn:=xlValues) If Not c Is Nothing Then firstAddress = c.Address y = 1 Do Range(c.Offset(0, 0), c.Offset(3, 1)).Cut Cells(y, 3) ' Range(c.Offset(0, 0), c.Offset(3, 1)).Copy ' Range(Cells(y, 3), Cells(y, 4)).PasteSpecial Set c = .FindNext(c) y = y + 4 Loop While Not c Is Nothing And c.Address < firstAddress End If End With timetoquit: End Sub -- Don Guillett Microsoft MVP Excel SalesAid Software wrote in message roups.com... So far I have looked at many examples and i have tried many ways but I have yet to figure out how to do a real cut and paste. So far in all my codes I have been able to do a copy and paste and then a delete selction but I can't this time. So hopefully someone can help me out. My code is as follows... With Worksheets(1).Range("A1:A500") Set c = .Find("Substrate # 2", LookIn:=xlValues) If Not c Is Nothing Then firstAddress = c.Address y = 1 Do Range(c.Offset(0, 0), c.Offset(3, 1)).Copy Range(Cells(y, 3), Cells(y, 4)).PasteSpecial Set c = .FindNext(c) y = y + 4 Loop While Not c Is Nothing And c.Address < firstAddress End If End With I want it to cut and paste rather than copy and paste. I have tried taking out the copy replacing it with a cut didn't work then tried setting the ranges and ranges using the Dim function. I need help please.- Hide quoted text - - Show quoted text - that does not work it only cuts and pastes once for each substrate. It doesn't loop the cut and paste.- Hide quoted text - - Show quoted text - Tom, This is the basics of my script layout. A B Item1 Temp Thickness Amount Item1 Temp Thickness Amount Item1 Temp Thickness Amount Item1 Temp Thickness Amount Item2 Temp Thickness Amount Item2 Temp Thickness Amount Item2 Temp Thickness Amount Item2 Temp Thickness Amount Item3 Temp Thickness Amount Item3 Temp Thickness Amount Item3 Temp Thickness Amount Item3 Temp Thickness Amount There are more items but this is enought o get the point across. I am trying to make this column into rows by item number. like this A B C D E F Item1 Temp Item2 Temp Item3 Temp Thickness Thickness Thickness Amount Amount Amount Item1 Temp Item2 Temp Item3 Temp Thickness Thickness Thickness Amount Amount Amount Item1 Temp Item2 Temp Item3 Temp Thickness Thickness Thickness Amount Amount Amount Item1 Temp Item2 Temp Item3 Temp Thickness Thickness Thickness Amount Amount Amount I hope this helps better understand what is going on. The code you gave me didn't work either Thank you for all the help you have been -Carlos |
A real cut and paste
I think the idea may be to go from the bottom up. Try this idea.
Sub findprevious() Do Until fc = " " Set fc = Worksheets("Sheet2").Columns("a").findprevious(aft er:=Cells(500, 1)) 'not quite sure what you want here? [fc].Cut [fc].Offset(, 8) Loop End Sub -- Don Guillett Microsoft MVP Excel SalesAid Software "Don Guillett" wrote in message ... Send ME a sample workbook if desired along with before and after examples. Pls TOP post in this group -- Don Guillett Microsoft MVP Excel SalesAid Software wrote in message ups.com... On Jul 9, 9:44 am, "Don Guillett" wrote: try Sub cutpaste() On Error GoTo timetoquit With Worksheets("sheet2").Range("A1:A500") Set c = .Find("s", LookIn:=xlValues) If Not c Is Nothing Then firstAddress = c.Address y = 1 Do Range(c.Offset(0, 0), c.Offset(3, 1)).Cut Cells(y, 3) ' Range(c.Offset(0, 0), c.Offset(3, 1)).Copy ' Range(Cells(y, 3), Cells(y, 4)).PasteSpecial Set c = .FindNext(c) y = y + 4 Loop While Not c Is Nothing And c.Address < firstAddress End If End With timetoquit: End Sub -- Don Guillett Microsoft MVP Excel SalesAid Software wrote in message oups.com... So far I have looked at many examples and i have tried many ways but I have yet to figure out how to do a real cut and paste. So far in all my codes I have been able to do a copy and paste and then a delete selction but I can't this time. So hopefully someone can help me out. My code is as follows... With Worksheets(1).Range("A1:A500") Set c = .Find("Substrate # 2", LookIn:=xlValues) If Not c Is Nothing Then firstAddress = c.Address y = 1 Do Range(c.Offset(0, 0), c.Offset(3, 1)).Copy Range(Cells(y, 3), Cells(y, 4)).PasteSpecial Set c = .FindNext(c) y = y + 4 Loop While Not c Is Nothing And c.Address < firstAddress End If End With I want it to cut and paste rather than copy and paste. I have tried taking out the copy replacing it with a cut didn't work then tried setting the ranges and ranges using the Dim function. I need help please.- Hide quoted text - - Show quoted text - that does not work it only cuts and pastes once for each substrate. It doesn't loop the cut and paste. |
A real cut and paste
|
A real cut and paste
This may????? do it. There are other ways
Sub makerowsfromcolumns() For i = 2 To Cells(Rows.Count, "a").End(xlUp).Row Step 3 Cells(i, 3) = Cells(i, 1) Cells(i, 4) = Cells(i + 1, 2) Cells(i, 5) = Cells(i + 2, 2) Cells(i, 6) = Cells(i + 3, 2) Next i Columns("a:b").Delete Columns("a").SpecialCells(xlBlanks).EntireRow.Dele te End Sub Item1 Thickness Amount Temp Item1 Thickness Amount Temp Item1 Thickness Amount Temp Item1 Thickness Amount Temp Item2 Thickness Amount Temp Item2 Thickness Amount Temp Item2 Thickness Amount Temp Item2 Thickness Amount Temp Item3 Thickness Amount Temp Item3 Thickness Amount Temp Item3 Thickness Amount Temp Item3 Thickness Amount -- Don Guillett Microsoft MVP Excel SalesAid Software wrote in message ps.com... On Jul 9, 10:20 am, Tom Ogilvy wrote: Maybe something like this. It isn't clear to me where you actually want to place the cells you find - so I put them below the data before deleting the rows. Dim c as Range, r as Range, r1 as Range With Worksheets(1).Range("A1:A500") Set c = .Find("Substrate # 2", LookIn:=xlValues) If Not c Is Nothing Then firstAddress = c.Address Do set r = Range(c.Offset(0, 0), c.Offset(3, 1)) if r1 is nothing then set r1 = r else set r1 = union(r1,r) end if Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address < firstAddress if not r1 is nothing then r1.copy cells(rows.count,1).End(xlup).offset(0,4).PasteSpe cial r1.EntireRow.Delete end if End If End With -- Regards, Tom Ogilvy " wrote: On Jul 9, 9:44 am, "Don Guillett" wrote: try Sub cutpaste() On Error GoTo timetoquit With Worksheets("sheet2").Range("A1:A500") Set c = .Find("s", LookIn:=xlValues) If Not c Is Nothing Then firstAddress = c.Address y = 1 Do Range(c.Offset(0, 0), c.Offset(3, 1)).Cut Cells(y, 3) ' Range(c.Offset(0, 0), c.Offset(3, 1)).Copy ' Range(Cells(y, 3), Cells(y, 4)).PasteSpecial Set c = .FindNext(c) y = y + 4 Loop While Not c Is Nothing And c.Address < firstAddress End If End With timetoquit: End Sub -- Don Guillett Microsoft MVP Excel SalesAid Software wrote in message roups.com... So far I have looked at many examples and i have tried many ways but I have yet to figure out how to do a real cut and paste. So far in all my codes I have been able to do a copy and paste and then a delete selction but I can't this time. So hopefully someone can help me out. My code is as follows... With Worksheets(1).Range("A1:A500") Set c = .Find("Substrate # 2", LookIn:=xlValues) If Not c Is Nothing Then firstAddress = c.Address y = 1 Do Range(c.Offset(0, 0), c.Offset(3, 1)).Copy Range(Cells(y, 3), Cells(y, 4)).PasteSpecial Set c = .FindNext(c) y = y + 4 Loop While Not c Is Nothing And c.Address < firstAddress End If End With I want it to cut and paste rather than copy and paste. I have tried taking out the copy replacing it with a cut didn't work then tried setting the ranges and ranges using the Dim function. I need help please.- Hide quoted text - - Show quoted text - that does not work it only cuts and pastes once for each substrate. It doesn't loop the cut and paste.- Hide quoted text - - Show quoted text - Tom, This is the basics of my script layout. A B Item1 Temp Thickness Amount Item1 Temp Thickness Amount Item1 Temp Thickness Amount Item1 Temp Thickness Amount Item2 Temp Thickness Amount Item2 Temp Thickness Amount Item2 Temp Thickness Amount Item2 Temp Thickness Amount Item3 Temp Thickness Amount Item3 Temp Thickness Amount Item3 Temp Thickness Amount Item3 Temp Thickness Amount There are more items but this is enought o get the point across. I am trying to make this column into rows by item number. like this A B C D E F Item1 Temp Item2 Temp Item3 Temp Thickness Thickness Thickness Amount Amount Amount Item1 Temp Item2 Temp Item3 Temp Thickness Thickness Thickness Amount Amount Amount Item1 Temp Item2 Temp Item3 Temp Thickness Thickness Thickness Amount Amount Amount Item1 Temp Item2 Temp Item3 Temp Thickness Thickness Thickness Amount Amount Amount I hope this helps better understand what is going on. The code you gave me didn't work either Thank you for all the help you have been -Carlos |
A real cut and paste
This seems to do what was requested
Public pn Sub fixvalues() pn = Cells(1, 1) lr = Cells(Rows.Count, "a").End(xlUp).Row mc = 3 For i = 1 To lr Step 2 If Cells(i, 1) < pn Then mc = mc + 2 dlr = Cells(Rows.Count, mc).End(xlUp).Row + 2 Cells(i, 1).Resize(2, 2).Copy Cells(dlr, mc) pn = Cells(i, 1) Next i Columns("a:b").Delete Rows("1:2").Delete End Sub -- Don Guillett Microsoft MVP Excel SalesAid Software "Don Guillett" wrote in message ... This may????? do it. There are other ways Sub makerowsfromcolumns() For i = 2 To Cells(Rows.Count, "a").End(xlUp).Row Step 3 Cells(i, 3) = Cells(i, 1) Cells(i, 4) = Cells(i + 1, 2) Cells(i, 5) = Cells(i + 2, 2) Cells(i, 6) = Cells(i + 3, 2) Next i Columns("a:b").Delete Columns("a").SpecialCells(xlBlanks).EntireRow.Dele te End Sub Item1 Thickness Amount Temp Item1 Thickness Amount Temp Item1 Thickness Amount Temp Item1 Thickness Amount Temp Item2 Thickness Amount Temp Item2 Thickness Amount Temp Item2 Thickness Amount Temp Item2 Thickness Amount Temp Item3 Thickness Amount Temp Item3 Thickness Amount Temp Item3 Thickness Amount Temp Item3 Thickness Amount -- Don Guillett Microsoft MVP Excel SalesAid Software wrote in message ps.com... On Jul 9, 10:20 am, Tom Ogilvy wrote: Maybe something like this. It isn't clear to me where you actually want to place the cells you find - so I put them below the data before deleting the rows. Dim c as Range, r as Range, r1 as Range With Worksheets(1).Range("A1:A500") Set c = .Find("Substrate # 2", LookIn:=xlValues) If Not c Is Nothing Then firstAddress = c.Address Do set r = Range(c.Offset(0, 0), c.Offset(3, 1)) if r1 is nothing then set r1 = r else set r1 = union(r1,r) end if Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address < firstAddress if not r1 is nothing then r1.copy cells(rows.count,1).End(xlup).offset(0,4).PasteSpe cial r1.EntireRow.Delete end if End If End With -- Regards, Tom Ogilvy " wrote: On Jul 9, 9:44 am, "Don Guillett" wrote: try Sub cutpaste() On Error GoTo timetoquit With Worksheets("sheet2").Range("A1:A500") Set c = .Find("s", LookIn:=xlValues) If Not c Is Nothing Then firstAddress = c.Address y = 1 Do Range(c.Offset(0, 0), c.Offset(3, 1)).Cut Cells(y, 3) ' Range(c.Offset(0, 0), c.Offset(3, 1)).Copy ' Range(Cells(y, 3), Cells(y, 4)).PasteSpecial Set c = .FindNext(c) y = y + 4 Loop While Not c Is Nothing And c.Address < firstAddress End If End With timetoquit: End Sub -- Don Guillett Microsoft MVP Excel SalesAid Software wrote in message roups.com... So far I have looked at many examples and i have tried many ways but I have yet to figure out how to do a real cut and paste. So far in all my codes I have been able to do a copy and paste and then a delete selction but I can't this time. So hopefully someone can help me out. My code is as follows... With Worksheets(1).Range("A1:A500") Set c = .Find("Substrate # 2", LookIn:=xlValues) If Not c Is Nothing Then firstAddress = c.Address y = 1 Do Range(c.Offset(0, 0), c.Offset(3, 1)).Copy Range(Cells(y, 3), Cells(y, 4)).PasteSpecial Set c = .FindNext(c) y = y + 4 Loop While Not c Is Nothing And c.Address < firstAddress End If End With I want it to cut and paste rather than copy and paste. I have tried taking out the copy replacing it with a cut didn't work then tried setting the ranges and ranges using the Dim function. I need help please.- Hide quoted text - - Show quoted text - that does not work it only cuts and pastes once for each substrate. It doesn't loop the cut and paste.- Hide quoted text - - Show quoted text - Tom, This is the basics of my script layout. A B Item1 Temp Thickness Amount Item1 Temp Thickness Amount Item1 Temp Thickness Amount Item1 Temp Thickness Amount Item2 Temp Thickness Amount Item2 Temp Thickness Amount Item2 Temp Thickness Amount Item2 Temp Thickness Amount Item3 Temp Thickness Amount Item3 Temp Thickness Amount Item3 Temp Thickness Amount Item3 Temp Thickness Amount There are more items but this is enought o get the point across. I am trying to make this column into rows by item number. like this A B C D E F Item1 Temp Item2 Temp Item3 Temp Thickness Thickness Thickness Amount Amount Amount Item1 Temp Item2 Temp Item3 Temp Thickness Thickness Thickness Amount Amount Amount Item1 Temp Item2 Temp Item3 Temp Thickness Thickness Thickness Amount Amount Amount Item1 Temp Item2 Temp Item3 Temp Thickness Thickness Thickness Amount Amount Amount I hope this helps better understand what is going on. The code you gave me didn't work either Thank you for all the help you have been -Carlos |
| All times are GMT +1. The time now is 02:49 AM. |
Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com