Convert multiple hyperlinks to buttons

Legacy 32120 · Jan 6, 2010

Hello folks!

Can hyperlinks be converted to buttons please?
I've a large number of links so a global conversion is what I'm hoping for.

Thanks muchly....

Max

P.S. I'm running Excel 2010

Gary McMaster · Jan 10, 2010

I don't have 2010 but the sample(s) below work for 2007.

Hope it helps.

Gary

Change the range in the code line shown below to point to your hyperlinks.

Set oLinks = Range("A1:A10")

The buttons will be placed in the column immediately to the right of the links.

Rich (BB code):

Public Sub Make_Buttons()
 
Dim oActive As Worksheet
Dim oLinks As Range
Dim oCell As Range
Dim oOffset As Range
Dim oLink As Hyperlink
Dim oButton As Shape
 
Set oActive = ActiveSheet
Set oLinks = Range("A1:A10")
 
For Each oCell In oLinks
    If oCell.Hyperlinks.Count <> 0 Then
    
        Set oOffset = oCell.Offset(0, 1)
        Set oButton = oActive.Shapes.AddShape(msoShapeRectangle, oOffset.Left + 2, oOffset.Top + 2, oOffset.Width - 4, oOffset.Height - 4)
            
        With oButton
            .Fill.ForeColor.RGB = RGB(255, 255, 255)
            .Line.ForeColor.RGB = RGB(0, 0, 0)
            .TextFrame.Characters.Font.ColorIndex = 0
            .TextFrame.Characters.Font.Size = 8
            .TextFrame.Characters.Text = oCell.Hyperlinks(1).TextToDisplay
            .Line.Style = msoLineThinThin
            'Adjust additional properties for desired appearance
        End With
        
        oActive.Hyperlinks.Add Anchor:=oButton, Address:=oCell.Hyperlinks(1).Address
        
        'Or:
        
        'Set oLink = oActive.Hyperlinks.Add(Anchor:=oButton, Address:=oCell.Hyperlinks(1).Address)
        'With oLink
           
        'End With
        
    End If
Next
 
End Sub

Caution: This will delete all rectangles on the sheet. Not just the buttons created by the above.

Rich (BB code):

Public Sub Delete_Buttons()
 
Dim oActive As Worksheet
Dim oShape As Shape
 
Set oActive = ActiveSheet
 
'Warning, this will delete ALL rectangles on the sheet
For Each oShape In oActive.Shapes
    If oShape.AutoShapeType = msoShapeRectangle Then
        oShape.Delete
    End If
Next oShape
 
End Sub

Legacy 32120 · Jan 10, 2010

Hi Gary!

Terrific! Many thanks...

Can this be also done with the =HYPERLINK() type of link?

Max Kramer

Gary McMaster · Jan 11, 2010

Max,

The short answer is yes.

The long answer is I've never used =HYPERLINK() and don't often mix VBA and worksheet functions. According to help, the display text and URL can be references to other cells. It seems that it could get complicated.

I'm not sure what the best way to go about it is and will probably be stepping into a mine field. I'm hoping someone else will bail us out. If not, I'll give it a shot this evening (USA EST).

Gary

GTO · Jan 11, 2010

Hi Max,

As Gary pointed out, the sheet function HYPERLINK would seem problematic if points to another cell that contains the address. So if your links are built like:

=HYPERLINK(Sheet3!D10,"OOPS")

Then I do not see a reasonably easy way of getting this done. If the links are like:

=HYPERLINK("http://www.cpearson.com/excel/","Chip's")

Then using Gary's code, maybe like:

Rich (BB code):

Public Sub Make_Buttons()
    
Dim oActive As Worksheet
Dim oLinks As Range
Dim oCell As Range
Dim oOffset As Range
Dim oLink As Hyperlink
Dim oButton As Shape
Dim strFormula As String
Dim strLink As String
Dim strFriendly As String
Dim REX As Object ' RegExp
    
Set oActive = ActiveSheet
Set oLinks = Range("A1:A10")
    
'=HYPERLINK("http://www.cpearson.com/excel/","Chip's")
Const PATTERN_LEFT As String = "=HYPERLINK\("""
Const PATTERN_RIGHT As String = ","""
    
Set REX = CreateObject("VBScript.RegExp")
With REX
    .Global = False
    .IgnoreCase = True
End With
    
For Each oCell In oLinks
    
    If oCell.HasFormula Then
        If oCell.Formula Like "=HYPERLINK(*" Then
            
            strFormula = oCell.Formula
            REX.Pattern = PATTERN_LEFT
            strLink = REX.Replace(strFormula, "")
            strFriendly = Mid(strLink, InStr(1, strLink, PATTERN_RIGHT) + 2, 255)
            strFriendly = Left(strFriendly, Len(strFriendly) - 2)
            strLink = Mid(strLink, 1, InStr(1, strLink, PATTERN_RIGHT) - 2)
            
            Set oOffset = oCell.Offset(0, 1)
            Set oButton = oActive.Shapes.AddShape(msoShapeRectangle, oOffset.Left + 2, oOffset.Top + 2, oOffset.Width - 4, oOffset.Height - 4)
            
            With oButton
                .Fill.ForeColor.RGB = RGB(255, 255, 255)
                .Line.ForeColor.RGB = RGB(0, 0, 0)
                '// not sure why problems here, I'm in 2000 and intellisense was showing?
                '// un-comment the next two lines if they were working w/o error
                '.TextFrame.Characters.Font.ColorIndex = 0
                '.TextFrame.Characters.Font.Size = 8
                .TextFrame.Characters.Text = strFriendly 'oCell.Hyperlinks(1).TextToDisplay
                .Line.Style = msoLineThinThin
                'Adjust additional properties for desired appearance
            End With
            
            oActive.Hyperlinks.Add Anchor:=oButton, Address:=strLink ', TextToDisplay:=strFriendly
        End If
    End If
Next
End Sub

A bit sloppy (Sorry Gary), but see if it seems to grab the addresses reliably (in a junk copy of your wb!)

Mark

Gary McMaster · Jan 11, 2010

GTO,

Thanks for the feedback. Maybe my short answer should be no.

I was hoping there was some kind of mechanism similar to "paste special" that would resolve the formulas down to the actual value (URL).

There doesn't seem to be any advantage to doing it as follows ("Hard coded" values for lack of a better term):

=HYPERLINK("http://www.google.com","Google")

IMO it be easier to just right click on the cell and assign the link directly rather than use the formula.

It must be primarily intended to be used with refs to other cells. That could get out of control very quickly. Especially if there is no consistency to the formula(s).

In "A2"
=HYPERLINK(B2,C2)

In "B2"
=D2

In "D2"
http://www.google.com

One may have to drill down through numerous references to get to the URL or Text. A "one size fits all" macro doesn't seem very likely.

Gary

GTO · Jan 11, 2010

Gary McMaster said:
GTO,

Thanks for the feedback. Maybe my short answer should be no.

...

It must be primarily intended to be used with refs to other cells. That could get out of control very quickly. Especially if there is no consistency to the formula(s).

In "A2"
=HYPERLINK(B2,C2)

In "B2"
=D2

In "D2"
http://www.google.com

One may have to drill down through numerous references to get to the URL or Text. A "one size fits all" macro doesn't seem very likely.

Gary

Hi Gary,

Well, I did admit that it didn't seem reasonably easy unless the target address and friendly were in string form.

That said, of course it bugged me... Started with drilling via .Precedents. I think .Precedents could work, but about the time I was getting that figured out, Evaluate suddenly seemed like the ticket.

See what you think

@makka:

Please test in a copy of your wb just in case, but I believe this may work.

Before, including "drill-downs" if present:

Excel Workbook

A

B

C

D

E

1

Old Link

Button

Link Precedent

Friendly Precedent

Link Precedent

2

Test

3

http://vbaexpress.com/forum/forumdisplay.php?f=17

4

5

Debra's

http://contextures.com/

6

7

My Doc

8

Test1

D:\110609M\011010\Blacklist.xls

Test1

9

10

Test 2

D:\110609M\011010\Blacklist.xls

11

12

Chip Pearson's

http://cpearson.com

Chip Pearson's

http://cpearson.com

Sheet2

In a Standard Module:
Option Explicit Public Sub Make_The_Damn_Buttons_No_Matter_What() Dim oActive As Worksheet Dim oLinks As Range Dim oCell As Range Dim oOffset As Range Dim oLink As Hyperlink Dim oButton As Shape Dim REX As Object '<--- RegExp Dim strLink As String Dim strFriendly As String Dim strRaw As String Dim bolHasFriendlyName As Boolean Set oActive = ActiveSheet Set oLinks = Range("A1:A12") Set REX = CreateObject("VBScript.RegExp") With REX .Global = True .IgnoreCase = True .Pattern = "=HYPERLINK\(|\)" End With For Each oCell In oLinks If oCell.HasFormula Then If oCell.Formula Like "=HYPERLINK(*" Then '// Rip everything between the parenthesis // strRaw = REX.Replace(oCell.Formula, vbNullString) '// See if there's a comma in there, which I think we should be safe in // '// presuming this means a friendlyname exists. // bolHasFriendlyName = Not InStr(1, strRaw, ",") = 0 If bolHasFriendlyName Then '// Use Evaluate to get the string(s), regardless of by reference // '// to another cell or by string in the HYPERLINK function. // strLink = Evaluate("=" & Split(strRaw, ",", 2)(0)) strFriendly = Evaluate("=" & Split(strRaw, ",", 2)(1)) Else strLink = Evaluate("=" & strRaw) strFriendly = "My Button" ' or strLeft End If Set oOffset = oCell.Offset(0, 1) Set oButton = oActive.Shapes.AddShape(msoShapeRectangle, _ oOffset.Left + 2, _ oOffset.Top + 2, _ oOffset.Width - 4, _ oOffset.Height - 4) With oButton .Fill.ForeColor.RGB = RGB(255, 255, 255) .Line.ForeColor.RGB = RGB(0, 0, 0) .TextFrame.Characters.Text = strFriendly '// I moved this to after there are characters // .TextFrame.Characters.Font.ColorIndex = 0 .TextFrame.Characters.Font.Size = 8 .Line.Style = msoLineThinThin 'Adjust additional properties for desired appearance End With oActive.Hyperlinks.Add Anchor:=oButton, Address:=strLink End If End If Next End Sub

Hope that helps,

Mark

Gary McMaster · Jan 11, 2010

Very nice.

Thanks for bailing me out Mark. Now I can take the night off

Gary

Legacy 32120 · Jan 11, 2010

Thanks Gary & Mark,

It converts 'function' links to 'embedded' links with buttons just fine!

Let me guess, can't have buttons with 'function' links because 'function' only works in cells?

Max

GTO · Jan 12, 2010

makka said:
Thanks Gary & Mark,

It converts 'function' links to 'embedded' links with buttons just fine!

Let me guess, can't have buttons with 'function' links because 'function' only works in cells?

Max

Max -

I'm very glad that worked. It was extremely educational for me!

I am afraid I do not understand your question

Gary McMaster said:
Very nice.

Thanks for bailing me out Mark. Now I can take the night off

Gary

Hey Gary,

Thank you very much. Took longer than it should have (last day of vacation(!), argh!!!!

That said, was most educational

and interesting!

Mark

Convert multiple hyperlinks to buttons

Legacy 32120

Guest

Excel Facts

Gary McMaster

Well-known Member

Legacy 32120

Guest

Gary McMaster

Well-known Member

GTO

MrExcel MVP

Gary McMaster

Well-known Member

GTO

MrExcel MVP

Gary McMaster

Well-known Member

Legacy 32120

Guest

GTO

MrExcel MVP

Similar threads

Forum statistics

Share this page

Convert multiple hyperlinks to buttons

Legacy 32120

Guest

Excel Facts

Gary McMaster

Well-known Member

Legacy 32120

Guest

Gary McMaster

Well-known Member

GTO

MrExcel MVP

Gary McMaster

Well-known Member

GTO

MrExcel MVP

Gary McMaster

Well-known Member

Legacy 32120

Guest

GTO

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock