Macro to move cells and delete lines

[Midas]

Hi, I have a file with 1000+ lines of data which needs to be rearranged. My macro-writing skills are essentially zero, so I am hoping someone on this forum can help.
What I need is a macro which can do the following :
1. In column A move every second line cell to column B at one line higher
2. Same for column G : move every second line cell to column H at one line higher
3. Each time delete the empty line after both cells are moved.

See image for the current and required view. Many thanks for your help !!

 

[mumps]

Try:'

Sub moveData()
    Application.ScreenUpdating = False
    Dim lRow As Long, x As Long
    lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For x = lRow To 2 Step -2
        Range("B" & x - 1) = Range("A" & x)
        Range("H" & x - 1) = Range("G" & x)
        Rows(x).Delete
    Next x
    Application.ScreenUpdating = False
End Sub

 

[rlv01]

One way.

Sub Demo()
    Dim WS As Worksheet, rng As Range, R As Range

    Set WS = ActiveSheet
    With WS
        Set rng = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
    End With

    For Each R In rng
        If R.Row Mod 2 = 0 Then
            R.Offset(-1, 1) = R.Value
            R.Value = vbNullString
            R.Offset(-1, 7) = R.Offset(0, 6)
            R.Offset(0, 6) = vbNullString
        End If
    Next R
    rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

 

[igold]

Another way that does not go back and forth to the sheet in the For/Next loop...

Sub test()

    Dim arr, x As Long, lRow As Long
    
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    arr = Range("A1:H" & lRow)
    For x = 1 To lRow Step 2
        If x + 1 > lRow Then Exit For
        arr(x, 2) = arr(x + 1, 1)
        arr(x, 8) = arr(x + 1, 7)
    Next

    Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    ActiveSheet.Columns("B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
End Sub

 

[Midas]

Try:'

Sub moveData()
    Application.ScreenUpdating = False
    Dim lRow As Long, x As Long
    lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For x = lRow To 2 Step -2
        Range("B" & x - 1) = Range("A" & x)
        Range("H" & x - 1) = Range("G" & x)
        Rows(x).Delete
    Next x
    Application.ScreenUpdating = False
End Sub

This works perfect ! All data is arranged as required in a blink of an eye !! Many thanks !!!

 

[mumps]

You are very welcome.

 

[Midas]

One way.

Sub Demo()
    Dim WS As Worksheet, rng As Range, R As Range

    Set WS = ActiveSheet
    With WS
        Set rng = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
    End With

    For Each R In rng
        If R.Row Mod 2 = 0 Then
            R.Offset(-1, 1) = R.Value
            R.Value = vbNullString
            R.Offset(-1, 7) = R.Offset(0, 6)
            R.Offset(0, 6) = vbNullString
        End If
    Next R
    rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

This works too ! Thank you so much !! You made my day !!!