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

thardy00

New Member
Joined
Jan 25, 2022
Messages
13
Office Version
  1. 2019
Platform
  1. Windows
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:
data example.jpg

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:
desired output example.jpg


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

Best regards,
Tom.
 

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
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

VBA 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

1643121803708.png


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

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

becomes

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

in my code above
 
Upvote 0

@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?
 
Upvote 0
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.
 
Upvote 0
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?
 
Upvote 0
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.
 
Upvote 0
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.
VBA Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,482
Messages
6,113,913
Members
448,532
Latest member
9Kimo3

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top