Move data in alternate rows to the next column without loosing the hyperlink function in the initial column

0

Dear Sirs,

This a variation of Question that has been raised before for similar question that has been solved by the help of Variatus by using a formula instead of a macro in the following link

https://www.teachexcel.com/talk/3699/move-data-on-alternate-row-to-column-by-using-macro

In the new scenario, I want the hyperlink function in the original column is still working.

I also attached a sample of a worksheet (File Move data from alternate rows to the next column).

I need to keep the data in the first row and the alternate row in the same sheet and next to each other.

The simulation data will be as follows

Original Data     Modified Data 
Column A     Column A Column B 
A1                 A1                A2 
A2                 
A3                 A3                A4 
A4     
A5                A5                 A6 
A6     
A7                A7                 A8 
A8     
A9                A9                 A10 
A10             
A11              A11                A12 
A12     
After moving the data in alternate row to the next column, I need to delete the original alternate row.(Delete row A2,A4,A6,A8,A10 etc), and the final data will be as follows :

Modified Data 
Column A    Column B 
A1                  A2 
A3                  A4 
A5                  A6 
A7                  A8 
A9                  A10 
A11                A12 
etc

I need the hyperlink function in the original column (Column A, ie A1, A3,A5,A7,A9 etc) is still working.

Looking forward to having your further help in this regards

Many thanks and best regards

Arsil Hadjar

Answer
Discuss

Answers

0
Selected Answer

Hi Arsil,

The problem with the previously suggested solution seems to have been that it didn't copy the hyperlinks as hyperlinks. I might have preferred to deal with that but it will take too much time to find out what is needed. Therefore I decided to put the whole thing into VBA the way you request. Please run this code from a standard code module.

Sub MergeAlternativeRows()
    ' 24 Jul 2019

    Dim Rl As Long
    Dim Rt() As Long, i As Long
    Dim R As Long
    Dim C As Long
    Dim Tmp As Variant, Rmax As Long

    With ThisWorkbook.Worksheets("Sheet2")              ' change as appropriate
        Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
        ReDim Rt(Rl)
        For R = 1 To Rl
            ' pick rows with hyperlinks in column A
            If .Cells(R, "A").Hyperlinks.Count Then
                Rt(i) = R
                i = i + 1
            End If
        Next R
        ReDim Preserve Rt(i - 1)

        Application.ScreenUpdating = False
        For i = UBound(Rt) To 0 Step -1
            C = 2                                       ' specified B as target column
            R = Rt(i) + 1
            If i < UBound(Rt) Then
                Rmax = Rt(i + 1) - 1
            Else
                Rmax = Rl
            End If

            Do While R <= Rmax
                Tmp = Trim(.Cells(R, "A").Value)
                If Len(Tmp) Then
                    .Cells(Rt(i), C).Value = Tmp
                    C = C + 1
                End If
                R = R + 1
            Loop

            ' delete non-hyperlink rows
            For R = Rmax To (Rt(i) + 1) Step -1
                .Rows(R).EntireRow.Delete
            Next R
        Next i
        Application.ScreenUpdating = True
    End With
End Sub

The code is a little more complicated than it probably needed to be because I mistook some of the rows in your original data as being blank. As the code is now it would ignore blank rows completely but if there is more than one row between hyperlinks the non-blank cells from column A would be copied to columns B, C etc. So, just make sure that they don't over-write anything in those columns.

I hope this solves your problem. Have a good day!

Discuss

Discussion

Dear Variatus,

I tried to run the code from the standard module to the attached file in this thread it returns to the following error message 

        Run-time error'9':
        Subscript of Out of range

When I click the debug button, it indicates the code stop at the following step

        With ThisWorkbook.Worksheets("Sheet2")              ' change as appropriate

Looking forward to your further advice in this regards

Many thanks and best regards
Arsil Hadjar
Arsil (rep: 32) Jul 24, '19 at 7:46 am
Hello Arsil, the error indicates that there is no worksheet by the name of "Sheet2" in the workbook into which you pasted the code. That's why I added the comment "change as appropriate" to that line. You must specify the name of a tab which exists, more precisely, you should specify the name of the sheet on which the code is supposed to take action.
The idea is that the code would be in the same workbook. If it isn't, change ThisWorkbook to ActiveWorkbook. That might produce unexpected results if you accidentally run the code while an unintended workbook is active. I don't recommend that but it would work.
Variatus (rep: 2998) Jul 24, '19 at 9:46 pm

Dear Variatus,

I Follow your suggestion to

------change ThisWorkbook to ActiveWorkbook and rerun the code from the standard module on the file attached on this thread, it seems the code is working with no error message until finishing but the result returns to no output.

-------put the code in the same workbook and rerun the code, also it seems the code is working with no error message until finishing but the result returns to no output.

Would it be possible for you to rerun the code from the file attached in this thread to confirm whether a similar situation occurred

Many thanks for the help and support so far

Arsil Hadjar
Arsil (rep: 32) Jul 25, '19 at 3:16 am
The line of code For i = UBound(Rt) To (UBound(Rt) - 2) Step -1 limits execution to only 2 rows at the bottom of the sheet. I introduced this for testing the code and forgot to remove the limitation. Sorry about that. The correct code should have For i = UBound(Rt) To 0 Step -1. I have implemented this change in my answer above.
Variatus (rep: 2998) Jul 27, '19 at 12:31 am
Add to Discussion

Answer the Question

You must create an account to use the forum. Create an Account or Login