Advertisement
artur99

Untitled

Sep 26th, 2019
337
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Sub OpenLinks()
  2.     Dim Cell As Range
  3.    
  4.     Set LinkRng = Range("E:E").EntireColumn.Resize(Rows.Count - 1).Offset(1)
  5.    
  6.     On Error Resume Next
  7.     For Each Cell In LinkRng.Cells
  8.         If Cell.Hyperlinks.Count >= 1 Then
  9.             Cell.Hyperlinks(1).Follow
  10.         Else
  11.             If InStr(Cell.Value, ".") Then
  12.                 If InStr(Cell.Value, "://") Then
  13.                     ThisWorkbook.FollowHyperlink (Cell.Value)
  14.                 Else
  15.                     ThisWorkbook.FollowHyperlink ("http://" & Cell.Value)
  16.                 End If
  17.             End If
  18.         End If
  19.        
  20.     Next
  21.     On Error GoTo 0
  22. End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement