CODEWITHSUNDEEP
vbaexcel
SLang
SLang

Reputation: 5

Moving a range of cells to another location within the active sheet

I'm trying to create a VBA macro to move the yellow highlight cells to the green cell just like how you see it in the picture below. I tried to use a offset code but I can't get it to offset a range of cells, A3 - I3 to J2 - R2.

The amount of rows of information can be from 40 to 900 lines, so I would need something that would continue moving cells over until there isn't any more information in Columns A-I.

The ideal result show reflect like this for as many rows as needed.

I'm still pretty new the VBA world and have created some for other proposes but I just can't seem tot figure this one out.

----UPDATE JAN 22 2018----

I actually resolved this with those code. I have i as 4 because there are often times that the first 5 rows do not need to be moved. Found this out as I was testing

Sub ()
Dim i As Long, lastRow As Long, rngToMove As Range

lastRow = Worksheets("cxl macro test").Cells(1048576, 1).End(xlUp).Row

For i = 4 To lastRow
    If Worksheets("cxl macro test").Cells(i, 1) = "" And Worksheets("cxl macro test").Cells(i - 3, 1) = "" Then
        Worksheets("cxl macro test").Cells(i - 2, 10) = Worksheets("cxl macro test").Cells(i - 1, 1)
        Worksheets("cxl macro test").Cells(i - 1, 1) = ""
    End If
    If Worksheets("cxl macro test").Cells(i, 1) = "" And Worksheets("cxl macro test").Cells(i - 3, 1) = "" Then
        Worksheets("cxl macro test").Cells(i - 2, 11) = Worksheets("cxl macro test").Cells(i - 1, 2)
        Worksheets("cxl macro test").Cells(i - 1, 2) = ""
    End If
    If Worksheets("cxl macro test").Cells(i, 1) = "" And Worksheets("cxl macro test").Cells(i - 3, 1) = "" Then
        Worksheets("cxl macro test").Cells(i - 2, 12) = Worksheets("cxl macro test").Cells(i - 1, 3)
        Worksheets("cxl macro test").Cells(i - 1, 3) = ""
    End If
    If Worksheets("cxl macro test").Cells(i, 1) = "" And Worksheets("cxl macro test").Cells(i - 3, 1) = "" Then
        Worksheets("cxl macro test").Cells(i - 2, 13) = Worksheets("cxl macro test").Cells(i - 1, 4)
        Worksheets("cxl macro test").Cells(i - 1, 4) = ""
    End If
    If Worksheets("cxl macro test").Cells(i, 1) = "" And Worksheets("cxl macro test").Cells(i - 3, 1) = "" Then
        Worksheets("cxl macro test").Cells(i - 2, 14) = Worksheets("cxl macro test").Cells(i - 1, 5)
        Worksheets("cxl macro test").Cells(i - 1, 5) = ""
    End If
    If Worksheets("cxl macro test").Cells(i, 1) = "" And Worksheets("cxl macro test").Cells(i - 3, 1) = "" Then
        Worksheets("cxl macro test").Cells(i - 2, 15) = Worksheets("cxl macro test").Cells(i - 1, 6)
        Worksheets("cxl macro test").Cells(i - 1, 6) = ""
    End If
    If Worksheets("cxl macro test").Cells(i, 1) = "" And Worksheets("cxl macro test").Cells(i - 3, 1) = "" Then
        Worksheets("cxl macro test").Cells(i - 2, 16) = Worksheets("cxl macro test").Cells(i - 1, 7)
        Worksheets("cxl macro test").Cells(i - 1, 7) = ""
    End If
    If Worksheets("cxl macro test").Cells(i, 1) = "" And Worksheets("cxl macro test").Cells(i - 3, 1) = "" Then
        Worksheets("cxl macro test").Cells(i - 2, 17) = Worksheets("cxl macro test").Cells(i - 1, 8)
        Worksheets("cxl macro test").Cells(i - 1, 8) = ""
    End If
    If Worksheets("cxl macro test").Cells(i, 1) = "" And Worksheets("cxl macro test").Cells(i - 3, 1) = "" Then
        Worksheets("cxl macro test").Cells(i - 2, 18) = Worksheets("cxl macro test").Cells(i - 1, 9)
        Worksheets("cxl macro test").Cells(i - 1, 9) = ""
    End If
Next i

Although for some reason, I can't get it to review the last row of contents and it doesn't move the required row. the last row of physical data is 526 but I get the same result when I use a smaller example with the last row being 70.

Does anyone know how I should tweek it?

Upvotes: 0

Views: 2154

Answers (3)

SLang
SLang

Reputation: 5

This was solved by adding +2 at the end of my tweaked code

lastRow = Worksheets("cxl macro test").Cells(Rows.Count, "A").End(xlUp).Row + 2

​thank you all for helping!!!

Upvotes: 0

Alex P
Alex P

Reputation: 12487

Try this.

Sub CopyCells()
    Dim i As Long, lastRow As Long, rngToMove As Range

    lastRow = Worksheets("Sheet1").Range("I" & Rows.Count).End(xlUp).Row

    For i = 1 To lastRow - 1 Step 3
        Set rngToMove = Range("A" & i + 1 & ":I" & i + 1)
        rngToMove.Cut Destination:=Range("J" & i)
    Next i
End Sub

Assumes:

  • Data starts in row 1 and contained in columns A to I
  • There is a blank row that separates the data blocks

Upvotes: 1

user7728112
user7728112

Reputation: 82

I would use a for loop here. 

ur = Sheets(YourSheetName).UsedRange.Rows.Count
For Each rw In ur
If sheets(YourSheetname).Range("A" & ur+1).Value = "" Then
'YOUR COPY PASTE CODE HERE'
else
End If
Next rw

Upvotes: 0

Related Questions