A real cut and paste

[carlos_ray86]

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.

 

[Don Guillett]

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

 

[carlos_ray86]

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









- Show quoted text -

that does not work it only cuts and pastes once for each substrate. It
doesn't loop the cut and paste.

 

[Don Guillett]

Send ME a sample workbook if desired along with before and after examples.
Pls TOP post in this group

 

[Guest]

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).PasteSpecial
r1.EntireRow.Delete
end if
End If
End With

 

[carlos_ray86]

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).PasteSpecial
r1.EntireRow.Delete
end if
End If
End With

--
Regards,
Tom Ogilvy






- 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

 

[Don Guillett]

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(after:=Cells(500,
1))

'not quite sure what you want here?
[fc].Cut [fc].Offset(, 8)

Loop
End Sub

 

[Guest]

I can't figure out what you want since you data is all jumbled up in the
posting (for me anyway).

If you want to send a sample workbook that illustrates before and after to
(e-mail address removed) I am sure we can work something out.

 

[Don Guillett]

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.Delete
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]

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