I was asked to create a script to check and mark hyperlinks. The following VBA script marks the cells which contains a hyperlink with no match with the color red:
Sub HyperLinkCheck()
Dim hypLink As Hyperlink
Dim shtSheet As Worksheet
Dim dirFile As String
For Each shtSheet In Worksheets
For Each hypLink In shtSheet.Hyperlinks
dirFile = hypLink.Address
If Len(Dir(dirFile)) > 0 Then
'MsgBox "File does exist"
Worksheets(shtSheet.Name).Range(hypLink.Range.Address).Interior.ColorIndex = xlNone 'no color
Else
'MsgBox "File does not exist"
Worksheets(shtSheet.Name).Range(hypLink.Range.Address).Interior.ColorIndex = 3 'red
End If
Next
Next
End Sub
Unfortunately, this script does not recognize hyperlinks created using the function HYPERLINJK. Therefore I created another script:
Sub HyperLinkTest()
Dim dirFile As String
Dim objCell As Range
For Each objCell In Sheets("hyperlink").UsedRange.Columns(4).Cells
dirFile = objCell.Value
If Len(Dir(dirFile)) > 0 Then
objCell.Interior.ColorIndex = xlNone 'no color
Else
objCell.Interior.ColorIndex = 3 'red
End If
Next
End Sub
This script specifically runs through the fourth column of a usedrange on sheet hyperlink.
Sub HyperLinkCheck()
Dim hypLink As Hyperlink
Dim shtSheet As Worksheet
Dim dirFile As String
For Each shtSheet In Worksheets
For Each hypLink In shtSheet.Hyperlinks
dirFile = hypLink.Address
If Len(Dir(dirFile)) > 0 Then
'MsgBox "File does exist"
Worksheets(shtSheet.Name).Range(hypLink.Range.Address).Interior.ColorIndex = xlNone 'no color
Else
'MsgBox "File does not exist"
Worksheets(shtSheet.Name).Range(hypLink.Range.Address).Interior.ColorIndex = 3 'red
End If
Next
Next
End Sub
Unfortunately, this script does not recognize hyperlinks created using the function HYPERLINJK. Therefore I created another script:
Sub HyperLinkTest()
Dim dirFile As String
Dim objCell As Range
For Each objCell In Sheets("hyperlink").UsedRange.Columns(4).Cells
dirFile = objCell.Value
If Len(Dir(dirFile)) > 0 Then
objCell.Interior.ColorIndex = xlNone 'no color
Else
objCell.Interior.ColorIndex = 3 'red
End If
Next
End Sub
This script specifically runs through the fourth column of a usedrange on sheet hyperlink.
Reacties