move cell values over 2 cells

[Rock]

I'm using the code below, which I found here) and this works fine to
delete the row I want, but I want another bit of code that will find a
different value and then move cell values over two cells.

Here's the Delete Row code (this one works very well)

Sub Deleterows()
Dim lastrow As Long, a As Long, b As Long
Application.ScreenUpdating = False
lastrow = Cells(Rows.Count, "a").End(xlUp).Row
For a = lastrow To 2 Step -1
If Cells(a, "b") = "Projected" Then
Rows(a).EntireRow.Delete
End If
Next a
End Sub

Now, I want to find the Word 'Subtotal' in column B, say one is in
cell B80. What I would like is to move what is in Cell C80, D80, E80,
F80, G80, H80, I80 over 2 cells. Then move (what would be the new
cell value from E80 and F80 back to the left one cell. When all is
done cell E80 would then be blank..make sense?

 

[Jay]

Hi Rock -

Please clarify. If you move C80-I80 to the right two cells, then move the
new E80 and F80 back to the left one cell, I don't think E80 will be blank
(will it?). I believe the maneuver you describe leaves F80 and C80 blank.

Jay

 

[Gleam]

Please try:
Sub MoveSubTs()
Dim lastrow As Long, a As Long
Application.ScreenUpdating = False
lastrow = Cells(Rows.Count, "a").End(xlUp).Row
For a = lastrow To 1 Step -1
If Cells(a, "b") = "Subtotal" Then
Cells(a, "c").Resize(1, 6).Cut Destination:=Cells(a, "e")
Cells(a, "e").Resize(1, 2).Cut Destination:=Cells(a, "d")
End If
Next a
End Sub

 

[Rock]

Hi Rock -

Please clarify. If you move C80-I80 to the right two cells, then move the
new E80 and F80 back to the left one cell, I don't think E80 will be blank
(will it?). I believe the maneuver you describe leaves F80 and C80 blank.

Jay








- Show quoted text -

right, it gets a bit confusing...I was thinking need to move c80:I80
over 3 cells, then E80 and F80 back to the left...leaving F80 blank
and C80 as well. I guess another why would move e80:I80 over 3, then
c80:d80 over 2...something like that. I recorded this step but I
don't know how to apply it or translate to code....

 

[Jay]

Rock -

Below is code that moves the 7 cells to the right 2 spaces, then moves two
cells back to the left 1 space. This maneuver leaves C80 and F80 blank as
you describe.

If you start by moving the 7 cells to the right 3 spaces, you will end up
with 3 blank cells in the row no matter what you do. So, the code below lets
you modify the offsets to get the result you desire by trial and error:

Sub ModifySubtotalRows_Ver3()
Dim lastrow As Long, a As Long, b As Long
lastrow = Cells(Rows.Count, "a").End(xlUp).Row

'-------------------------------------
'Rock - modify the offset values in these two statements as needed
offset1 = 2 'number of columns to move C-I to the right
offset2 = 1 'number of columns to move two cells back to the left
'---------------------------------------

For a = lastrow To 2 Step -1
If Cells(a, "b") = "SubTotal" Then
Set anchorCell = Cells(a, "c")
anchorCell.Resize(1, 7).Cut Destination:=anchorCell.Offset(0, offset1)
anchorCell.Resize(1, 2).Cut Destination:=anchorCell.Offset(0, -1 *
offset2)
End If
Next a
End Sub