Excel Macro - Every Second Row - Help Please

[paulm12]

Hi everyone,

I'm a new member here and decided to sign up after looking everywhere here already for a way to do this but I just can't find a good solution. If any of you guys have a spare minute to help me out I would really appreciate it.

Ok what I need to do is this:

I have a list of text rows in Column A and a list of URLs in Column B.

I need to take each row in column A and move each corresponding row in Column B below it and then add 1 blank row before move onto the next text row-->URL and then a blank row.

I'm probably not describing this very well so here is a visual example:

Column A Column B
​

This is row 1 text http://www.ThisIsTheURLInColumnB-row1.com
This is row 2 text http://www.ThisIsTheURLInColumnB-row2.com
This is row 3 text http://www.ThisIsTheURLInColumnB-row3.com
This is row 4 text http://www.ThisIsTheURLInColumnB-row4.com

Solution Needed:

This is row 1 text
http://www.ThisIsTheURLInColumnB-row1.com
(this is a blank row)
This is row 2 text
http://www.ThisIsTheURLInColumnB-row2.com
(this is a blank row)
This is row 3 text
http://www.ThisIsTheURLInColumnB-row3.com
(this is a blank row)
This is row 4 text
http://www.ThisIsTheURLInColumnB-row4.com

And so on...

Any help would be brilliant,
Paul

 

[Trebor76]

Hi Paul,

Welcome to forum!!

One quick question to start - is Column C always blank?

Robert

 

[paulm12]

Hi Robert thanks very much!

Yes Column C will always be blank.

Thanks for your speedy reply

 

[Haseeb Avarakkan]

Hello, Paul.

If you need a formula, C1, copy down this formula. Then Copy C:C then

Past Special >> Values >> OK. So this will convert to values. If you want then delete col A:B.

=IF(MOD(ROWS(C$1:C1),3),INDEX(A:B,INT((ROWS(C$1:C1)-1)/3)+1,MOD(ROWS(C$1:C1),3)),"")

 

[Trebor76]

See how the following macro goes:

Sub Macro1()

    Dim rItem As Range, _
        rMyData As Range
    Dim lRowStart As Long, _
        lRowLast As Long, _
        lRowPaste As Long
    
    lRowStart = 2 'Initial row number. Change to suit.
    lRowLast = _
        Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set rMyData = _
        Range("A2:A" & lRowLast)
    
    Application.ScreenUpdating = False
    
    For Each rItem In rMyData
        Range("A" & rItem.Row & ":C" & rItem.Row).Copy
        lRowPaste = _
            Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 2
        Range("A" & lRowPaste).PasteSpecial Transpose:=True
        Application.CutCopyMode = False
    Next rItem
    
    Range("A" & lRowStart).Select
    
    Application.ScreenUpdating = True

End Sub

HTH

Robert

 

[paulm12]

Hey aseeb,

I copied that formula into column C and kept dragging it down to reveal the solution! Only problem is I have thousands of rows to go through.

@Robert Your macro is working perfectly!

Quick question, how hard is it for the macro to move the solution into column C instead of appending it to the bottom of Column A?

Thanks again guys!

 

[Trebor76]

See how the following goes then - the only issue being when you say "thousands of rows to go through" whether you run out or rows or not with the additional blank row, and to a lesser extent how long it takes to run:

Sub Macro3()

    Dim rItem As Range, _
        rMyData As Range
    Dim lRowStart As Long, _
        lRowLast As Long, _
        lRowPaste As Long
    
    lRowStart = 2 'Initial row number. Change to suit.
    lRowLast = _
        Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set rMyData = _
        Range("A" & lRowStart & ":A" & lRowLast)
    
    Application.ScreenUpdating = False
    
    For Each rItem In rMyData
        Range("A" & rItem.Row & ":B" & rItem.Row).Copy
        If lRowPaste = 0 Then
            lRowPaste = lRowStart
            Range("C" & lRowPaste).PasteSpecial Transpose:=True
            Application.CutCopyMode = False
        Else
            lRowPaste = _
                Cells(Rows.Count, "C").End(xlUp).Row + 2
            Range("C" & lRowPaste).PasteSpecial Transpose:=True
            Application.CutCopyMode = False
        End If
    Next rItem
    
    Range("A" & lRowStart).Select
    
    Application.ScreenUpdating = True

End Sub

HTH

Robert

 

[paulm12]

I can't ask for any more than that Robert. It works flawlessly!

Thanks a million!

 

[Trebor76]

Glad to have helped