I'd like to create a VBA macro which would allow me to edit all selected hyperlinks in a column and change "text to display" to the same word for all. For example, if this was the column:
www.google.com/search=cars
www.google.com/search=houses
www.google.com/search=cities
I would want to highlight those three elements of the column and change the text to display to "Google Search" so that the outcome would be this:
Google Search
Google Search
Google Search
Edit: So I found a macro similar to what I want to do on the microsoft support site, but my issue is that this macro targets all the hyperlinks in the sheet while I'd want to select a specific column to edit the hyperlinks.
Sub HyperLinkChange()
Dim oldtext As String
Dim newtext As String
Dim h As Hyperlink
oldtext = "http://www.microsoft.com/"
newtext = "http://www.msn.com/"
For Each h In ActiveSheet.Hyperlinks
x = InStr(1, h.Address, oldtext)
If x > 0 Then
If h.TextToDisplay = h.Address Then
h.TextToDisplay = newtext
End If
h.Address = Application.WorksheetFunction. _
Substitute(h.Address, oldtext, newtext)
End If
Next End Sub
This works on the current selection:
Sub SetLinkText()
Dim LinkText As String
Dim h As Hyperlink
LinkText = InputBox("Enter link text")
If LinkText = "" Then Exit Sub
For Each h In Selection.Hyperlinks
h.TextToDisplay = LinkText
Next
End Sub
Related
I'm writing a VBA macro that find any font color used except from black (RGB: 0,0,0) and blue.
If this macro finds a character that isn't black and blue in a paragraph, it shows the text of the paragraph with a message box.
Option Explicit
Sub test()
Dim oParagraph As Paragraph, oLink As Hyperlink
Dim char As Range
Dim bFound As Boolean, i As Integer
Dim strHex As String, strHex1 As String, strHex2 As String, strHex3 As String
Dim strHex4 As String, strHex5 As String
bFound = False
For Each oParagraph In ActiveDocument.Paragraphs
For Each char In oParagraph.Range.Characters
strHex = Hex(char.Font.TextColor.RGB)
strHex1 = Hex(char.Font.ColorIndex)
strHex2 = Hex(char.Font.Color)
strHex3 = Hex(char.Style.Font.Color)
strHex4 = Hex(char.Style.Font.ColorIndex)
strHex5 = Hex(char.Style.Font.TextColor.RGB)
If char.Font.Color <> wdColorAutomatic And char.Font.Color <> wdColorBlack _
And char.Font.Color <> wdColorBlue Then
bFound = True
GoTo nt_lb
End If
Next char
Next oParagraph
nt_lb:
If bFound = True Then
MsgBox oParagraph.Range.Text
End If
End Sub
But, this macro doesn't work for a hyperlink.
When you execute this macro, this macro shows the pragraph including the hyperlink although the hyperlnk is blue and the remaining text is black in the paragraph.
My macro checks the following properties for getting the correct font color:
Range.Font.Color
Range.Font.TextColor
Range.Style.Font.Color
Range.Style.Font.TextColor
But, Any of the above properties don't return the correct color (blue).
In the hyperlink text "This is a test link.", this macro finds that the first "T" character isn't black and blue.
Also, I've attached a sample document.
Please help me.
I currently have a set of VB CATIA Macro codes that, when a user runs the code, it opens up a form that prompts the user to input the text that he/she wants to change.(See image for the form that will pop up) The code will then run through the whole drawings to search for and replace the text inputted by the user accordingly.
Currently, I am modifying the code so that the changes is to be applied to all the opened CAT Drawings.
What I want the code to do: User opens 5 CATIA drawings for example --> When user runs the code --> the Form opens up to prompt user to input Text to search for and Text to be replaced for --> Once user fills in for the two inputs and hit the 'Apply to all opened sheets' command button --> the code runs and changes all the 5 opened CATDrawings accordingly.
I'm new to the VB scripting language and have little to no experience with VB scripting language. Any help will be greatly appreciated.
Below are the working codes that will only apply the changes to 1 CATIA drawing opened.
'For the Module,
Sub CATMain()
MainForm.Show
End Sub
'For the Form,
Dim b As Variant
Dim a As String
Dim c As String
Dim selection1 As Selection
Dim drawingDocument1 As DrawingDocument
Private Sub CommandButton1_Click()
a = TextBox1.Value
b = TextBox2.Value
c = "CATDrwSearch.DrwText.TextString_CAP=*" & a & "*,all"
Set drawingDocument1 = CATIA.ActiveDocument
Set DrawSheets1 = drawingDocument1.Sheets
Set DrawSheet1 = DrawSheets1.ActiveSheet
Set selection1 = drawingDocument1.Selection
selection1.Search c
TextBox3 = selection1.Count
End Sub
Private Sub CommandButton2_Click()
a = TextBox1.Value
b = TextBox2.Value
c = "CATDrwSearch.DrwText.TextString_CAP=*" & a & "*,all"
Set drawingDocument1 = CATIA.ActiveDocument
Set selection1 = drawingDocument1.Selection
selection1.Search c
Text2 = selection1.Count
i = 1
For i = 1 To Text2
If Text2 > 0 Then
selection1.Item(i).Value.Text = b
End If
Next
End Sub
Private Sub CommandButton3_Click()
On Error Resume Next
Err.Clear
Set myCATIA = GetObject(, "CATIA.Application")
Dim myDocs As Documents
Set myDocs = myCATIA.Documents
Dim numofopeneddoc, n, j As Integer
numofopeneddoc = myDocs.Count
For n = 1 To numofopeneddoc
a = TextBox1.Value
b = TextBox2.Value
c = "CATDrwSearch.DrwText.TextString_CAP=*" & a & "*,all"
Set drawingDocument1 = CATIA.ActiveDocument
Set selection1 = drawingDocument1.Selection
selection1.Search c 'Starts the search
Text2 = selection1.Count
i = 1
For i = 1 To Text2
If Text2 > 0 Then
selection1.Item(i).Value.Text = b 'actual text replacement
End If
Next
Next n
End Sub
Alternatively, I also tried this method to no avail as well. Apparently, I can get around the .Selection portion
enter image description here
I have some cells in a worksheet that contain Inserted hyperlinks. I want to remove the hyperlinks and leave the "friendly name" in the cell. I can do this with:
Sub dural()
Dim h As Hyperlink
For Each h In ActiveSheet.Hyperlinks
h.Delete
Next h
End Sub
This little Sub works. However if I start with:
and run the macro, I get:
The format of the cell has been ruined! Is there anyway to remove the hyperlink and leave the formatting alone??
EDIT#1:
examining hyperlink properties, I got this to work:
Sub dural2()
Dim h As Hyperlink, addy As String, z As String
For Each h In ActiveSheet.Hyperlinks
addy = h.Range.Address
z = h.Parent
Range(addy).ClearContents
Range(addy).Value = z
Next h
End Sub
The Hyperlink object has certain properties which, through trial and error I established that, for a simple hyperlink to another cell on the same sheet:
h.Address = ""
h.Range = "CNN" (actually returns a Range but as the default property is .Value it evaluates to "CNN")
h.SubAddress = "Sheet1!C1"
As .SubAddress contains:
the location within the document associated with the hyperlink
I changed your code to:
Sub dural()
Dim h As Hyperlink
For Each h In ActiveSheet.Hyperlinks
h.SubAddress = ""
Next h
End Sub
and found that the hyperlink no longer works but your cell formatting is preserved.
I have a spreadsheet that is used for tracking work orders. The first column of the sheet has numbers starting at 14-0001 and continue sequentially all the way down. The numbers were hyperlinked to the .XLS of their respective work order (ex. the cell containing 14-0001 links to Z:\WorkOrders\14-0001-Task Name\14-0001-Task Name.xls)
Problem is, My computer crashed and when Excel recovered the file all the hyperlinks changed from:
**"Z:\blah blah\WorkOrders\14-****-Task Name\14-****-Task Name.xls"**
to
**"C:\Users\blahblah\WorkOrders\14-****-Task Name\14-****-Task Name.xls"**
There are hundreds of entries so I was hoping that I could run a script to fix all of the hyperlinks.
Heres a script I found online which from what I understood is supposed to do what I want, but when I run the script from the VB window in Excel I get "Compile error: Argument not optional" and it highlights Sub CandCHyperlinx()
Code:
Option Explicit
Sub CandCHyperlinx()
Dim cel As Range
Dim rng As Range
Dim adr As String
Dim delstring As String
'string to delete: CHANGE ME! (KEEP quotes!)
delstring = "C:\Users\***\AppData\Roaming\Microsoft\Excel\"
'get all cells as range
Set rng = ActiveSheet.UsedRange
'ignore non hyperlinked cells
On Error Resume Next
'check every cell
For Each cel In rng
'skip blank cells
If cel <> "" Then
'attempt to get hyperlink address
adr = cel.Hyperlinks(1).Address
'not blank? then correct it, is blank get next
If adr <> "" Then
'delete string from address
adr = Application.WorksheetFunction.Substitute(adr, delstring)
'put new address
cel.Hyperlinks(1).Address = adr
'reset for next pass
adr = ""
End If
End If
Next cel
End Sub
Is this even the right script? What am I doing wrong?
Try this:
Sub Macro1()
Const FIND_TXT As String = "C:\" 'etc
Const NEW_TXT As String = "Z:\" 'etc
Dim rng As Range, hl As Hyperlink
For Each rng In ActiveSheet.UsedRange.Cells
If rng.Hyperlinks.Count > 0 Then
Set hl = rng.Hyperlinks(1)
Debug.Print rng.Address(), "Before", hl.TextToDisplay, hl.Address
hl.TextToDisplay = Replace(hl.TextToDisplay, FIND_TXT, NEW_TXT)
hl.Address = Replace(hl.Address, FIND_TXT, NEW_TXT)
Debug.Print rng.Address(), "After", hl.TextToDisplay, hl.Address
End If
Next rng
End Sub
I've just had the same problem, and all the macros I tried didn't work for me. This one is adapted from Tim's above and from this thread Office Techcentre thread. In my case, all my hyperlinks were in column B, between rows 3 and 400 and 'hidden' behind the filename, and I wanted to put the links back to my Dropbox folder where they belong.
Sub FixLinks3()
Dim intStart As Integer
Dim intEnd As Integer
Dim strCol As String
Dim hLink As Hyperlink
intStart = 2
intEnd = 400
strCol = "B"
For i = intStart To intEnd
For Each hLink In ActiveSheet.Hyperlinks
hLink.TextToDisplay = Replace (hLink.TextToDisplay, "AppData/Roaming/Microsoft/Excel",
"Dropbox/References")
hLink.Address = Replace(hLink.Address, "AppData/Roaming/Microsoft/Excel",
"Dropbox/References")
Next hLink
Next i
End Sub
Thanks for your help, Tim!
We have migrated a server and transferred the files over using the same share path. My customer has got a word document with hyperlinks in it which point to the older server name.
i.e.
\\serverOld\accounts\1234.pdf and \\serverNew\accounts\1234.pdf
I have found this VB Script below that has done what i need but it is for Excel not Word.
Sub HyperLinkChange()
Dim oldtext As String
Dim newtext As String
Dim h As Hyperlink
' These can be any text portion of a hyperlink, such as ".com" or ".org".
oldtext = "\\topscan-server"
newtext = "\\ts-sbs"
' Check all hyperlinks on active sheet.
For Each h In ActiveSheet.Hyperlinks
x = InStr(1, h.Address, oldtext)
If x > 0 Then
If h.TextToDisplay = h.Address Then
h.TextToDisplay = newtext
End If
h.Address = Application.WorksheetFunction. _
Substitute(h.Address, oldtext, newtext)
End If
Next
End Sub
Please can someone help me edit this text to work with Microsoft Word 2010?
Try this
Sub HyperLinkChange()
Dim oldtext As String, newtext As String
Dim h As Hyperlink
oldtext = "\\topscan-server"
newtext = "\\ts-sbs"
For Each h In ActiveDocument.Hyperlinks
If InStr(1, h.Address, oldtext) Then
If h.TextToDisplay = h.Address Then
h.TextToDisplay = newtext
End If
h.Address = Replace(h.Address, oldtext, newtext)
End If
Next
End Sub