VBA for Row Transpose based on condition

[Jasmine1508]

Hi ...

Please find attached a document in the below reply of mine. i need assistance from you for the vba macros for the desired result as in the same attachment. Every Hyperlinked row is a starting of address.Manual transpose, cut and paste takes huge time. Require your help.

Thank you.

Jasmine

 

[Jasmine1508]

Attachement here.

 

[Thangavel]

Attachement here.

Hello,I didn't use any macros (checking on VBA possibility). I did using simple excel reference. First I filtered by color (select blue - hyperlinked cells). Cell B to F (Area ,Address,Contact Number , E-Mail ,Category) use '=' to all cells. Please refer the attached file for more info.
Regards,
Thangavel D

 

[Chihiro]

Sample VBA. Run it while you have Data sheet active.

Sub Demo()
Dim myArr
Dim cel As Range, myRange As Range
Dim i As Long: i = 1

Set myRange = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)

ReDim myArr(1 To myRange.Hyperlinks.Count, 1 To 6)

For Each cel In myRange.Cells
    If cel.Hyperlinks.Count = 1 Then
        iRow = cel.Row
        myArr(i, 1) = cel.Value
        myArr(i, 6) = cel.Hyperlinks(1).Address
    Else
        Select Case cel.Row
       
        Case Is = iRow + 1
            myArr(i, 2) = cel.Value
        Case Is = iRow + 2
            myArr(i, 3) = cel.Value
        Case Is = iRow + 3
            If InStr(cel.Value, "@") > 0 Then
                myArr(i, 4) = cel.Value
            Else
                myArr(i, 5) = cel.Value
                i = i + 1
            End If
        Case Is = iRow + 4
            myArr(i, 5) = cel.Value
            i = i + 1
        End Select
    End If
Next
           
With Sheet2
    i = 1
    .Range("B4").Resize(UBound(myArr), UBound(myArr, 2) - 1) = myArr
    For Each cel In .Range("B4:B" & .Cells(Rows.Count, 2).End(xlUp).Row).Cells
        cel.Hyperlinks.Add cel, myArr(i, 6)
        i = i + 1
    Next
End With

End Sub

 

[Jasmine1508]

Thanks for your valuable time Chihiro. It works great. Thank you so much

Regards.
Jasmine

Sample VBA. Run it while you have Data sheet active.

Sub Demo()
Dim myArr
Dim cel As Range, myRange As Range
Dim i As Long: i = 1

Set myRange = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)

ReDim myArr(1 To myRange.Hyperlinks.Count, 1 To 6)

For Each cel In myRange.Cells
    If cel.Hyperlinks.Count = 1 Then
        iRow = cel.Row
        myArr(i, 1) = cel.Value
        myArr(i, 6) = cel.Hyperlinks(1).Address
    Else
        Select Case cel.Row
      
        Case Is = iRow + 1
            myArr(i, 2) = cel.Value
        Case Is = iRow + 2
            myArr(i, 3) = cel.Value
        Case Is = iRow + 3
            If InStr(cel.Value, "@") > 0 Then
                myArr(i, 4) = cel.Value
            Else
                myArr(i, 5) = cel.Value
                i = i + 1
            End If
        Case Is = iRow + 4
            myArr(i, 5) = cel.Value
            i = i + 1
        End Select
    End If
Next
          
With Sheet2
    i = 1
    .Range("B4").Resize(UBound(myArr), UBound(myArr, 2) - 1) = myArr
    For Each cel In .Range("B4:B" & .Cells(Rows.Count, 2).End(xlUp).Row).Cells
        cel.Hyperlinks.Add cel, myArr(i, 6)
        i = i + 1
    Next
End With

End Sub

 

[Jasmine1508]

Thanks for your valuable time Thangavel. It works . Thank you so much.

Regards.
Jasmine

Hello,I didn't use any macros (checking on VBA possibility). I did using simple excel reference. First I filtered by color (select blue - hyperlinked cells). Cell B to F (Area ,Address,Contact Number , E-Mail ,Category) use '=' to all cells. Please refer the attached file for more info.
Regards,
Thangavel D