Solved: Help: Need VBA to Copy Each Autoshape Hyperlink to Another Cells

[loveguy1977]

Hi,

There is so many autoshapes with Hyperlink. I need to copy each Autoshape Hyperlink into a column.

I found a VBA that delete each autoshape Hyperlink. If you could modify this VBA to copy Autoshape Hyperlink or please help me to write new VBA


Sub Test()

Dim MyAddress As String
Dim MyText As String

On Error Resume Next
For x = 1 To ActiveSheet.Shapes.Count
ActiveSheet.Shapes(x).Select
MyAddress = Selection.ShapeRange.Item(1).Hyperlink.Address
MyText = Selection.ShapeRange.Item(1).Hyperlink.Text
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=MyAddress, TextToDisplay:=MyText
ActiveSheet.Shapes(x).Select
Selection.ShapeRange.Item(1).Hyperlink.Delete

Next x


End Sub

Thank you

[Bob Phillips]

Sub Test()
Dim Nextrow As Long
Dim i As Long

With ActiveSheet

Nextrow = 1
For i = 1 To .Shapes.Count

.Cells(Nextrow, "M").Value2 = .Shapes(i).Hyperlink.Address
Nextrow = Nextrow + 1
Next i
End With
End Sub