Move data from every second row to a column next to the previous row and delete empy row.

[thardy00]

Hi guys.
I'm Excel noob and I've got a sorting task to do. Manually I will do it for ages. That's why I'm kindly asking for your help.

I have a list of url links like this:

and I would like to move every second row to a column next to the previous row and delete empy row.
So it should look like that:

Is this even possible? Could someone help me with that please?

Best regards,
Tom.

 

[Siddharth Rout]

Yes Tom, it is possible. The best way that I can think of is to use array for this purpose. Here is an example.

LOGIC

1. Store the data in an array
2. Declare a 2nd array half the size of the above array and with 2 columns
3. Loop through the first array (skipping 1 row) and store the data in 2nd array
4. Finally write the 2nd array to relevant sheet

CODE

Option Explicit

Sub Sample()
    Dim ws As Worksheet, wsOutput As Worksheet
    Dim tmpAr As Variant
    Dim FinalAr As Variant
    Dim lRow As Long
    Dim i As Long
    Dim j As Long: j = 1
   
    '~~> This is the sheet which has the data
    Set ws = ThisWorkbook.Sheets("Sheet1")
   
    '~~> For demonstration, I am writing to sheet 2
    Set wsOutput = ThisWorkbook.Sheets("Sheet2")
   
    With ws
        '~~> Find last row in col A
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row
       
        '~~> Store the entire range in an array
        tmpAr = .Range("A1:A" & lRow).Value2
       
        '~~> Declare 2nd array with 2 columns and half the size of tmpAr
        ReDim FinalAr(1 To UBound(tmpAr) / 2, 1 To 2)
       
        '~~> Loop through tmpAr and skip 1 line
        '~~> and store the data in output array
        For i = LBound(tmpAr) To UBound(tmpAr) Step 2
            FinalAr(j, 1) = tmpAr(i, 1)
            FinalAr(j, 2) = tmpAr(i + 1, 1)
            j = j + 1
        Next i
    End With
   
    '~~> Write the output array to relevant sheet
    wsOutput.Range("A1").Resize(UBound(FinalAr), 2).Value = FinalAr
End Sub

SCREENSHOT

Note: In my sample above the data starts from row 1. If your data starts from row 2 then

 tmpAr = .Range("A1:A" & lRow).Value2

becomes

 tmpAr = .Range("A2:A" & lRow).Value2

in my code above

 

[thardy00]

@Siddharth Rout​

Thank you very much. It's working as charm. Could you please help me with doing one more little adjustment. It's all good but I would like to have output from column B in column J instead of B. Is this possible to do so?

 

[Siddharth Rout]

Do you want the output in a new sheet? If yes, then we can easily use .Resize as I have demonstrated above. If not, then we will have to loop the array and then write to cells individually to prevent overwriting of data.

 

[thardy00]

Could you show me both ways? I know a bit of Python and I'm trying to figure this code out myself but it is too hard for me.

BTW How can I thank you for all the help?

 

[thardy00]

@Siddharth Rout

 

[Joe4]

@Siddharth Rout

Responders are notified with a response is made to a thread they are involved in, so there is usually no need to tag them.
Just be aware that users are usually not on-line 24 hours a day, so they might not respond right away.
So sometimes you may need to wait a bit for them to get back to you.

 

[thardy00]

Oh didn't know that, sorry.

 

[Joe4]

Oh didn't know that, sorry.

No worries. I see that you are new here, so just wanted to let you know that.

 

[Joe4]

Hopefully, Siddharth with post back with amendments to his code.

In the meantime, here is a different method I came up with that should do what you want.
I don't know if it will be as efficient to the method that Siddharth was trying to use, but it should work.

Sub MyMoveRows()

    Dim lr As Long
    Dim r As Long
    Dim rng As Range
    
    Application.ScreenUpdating = False
    
'   Find last row in column A with data
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    
'   Build range of column A, every other row, starting with row 3
    For r = 3 To lr Step 2
        If rng Is Nothing Then
            Set rng = Cells(r, "A")
        Else
            Set rng = Application.Union(rng, Cells(r, "A"))
        End If
    Next r
        
'   Copy range to column A, below last row
    rng.Copy Cells(lr + 2, "A")
    
'   Delete rows
    rng.EntireRow.Delete
    
'   Moved data from bottom of column A to column J starting on row 2
    Cells(Rows.Count, "A").End(xlUp).CurrentRegion.Cut
    Range("J2").Activate
    ActiveSheet.Paste
    
    Application.ScreenUpdating = True
    
End Sub