loveguy1977
08-09-2011, 01:37 PM
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
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