Extracting Hyperlinks

[SAM2203]

Dear All,

I have a problem and I hope that you guys will be a great help. I have a column of hyperlinks (around 500 entries) now I want to extract hyperlinks of all entries in to a adjacent column.

What is the easiest way of doing it besides manually copying the links in to the destination cells


Thanks

 

[SAM2203]

Hello Sami,

Can't believe i did that. I even named the variable "Organizer". Here is the updated code...

'Written: April 28, 2011
'Author:  Leith Ross

Sub GetWebsiteAndOrganizer()
 
 'Updated version
 
  Dim Cell As Range
  Dim Cnt As Long
  Dim Data() As Variant
  Dim I As Long, N As Long
  Dim Organizer As String
  Dim Rng As Range
  Dim RngEnd As Range
  Dim Status As String
  Dim Wks As Worksheet
  Dim Website As String
  
    Set Wks = Worksheets("Sheet1")
    
    Set Rng = Wks.Range("B2")
    Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
    If RngEnd.Row < Rng.Row Then Exit Sub Else Set Rng = Wks.Range(Rng, RngEnd)
    
      ReDim Data(Rng.Rows.Count - 1, 1)
      
      For Each Cell In Rng
        Status = GetURLStatus(Cell.Text, True)
        If UCase(Status) Like "*OK*" Then
           I = InStr(1, PageSource, "Website: ")
           Website = Mid(PageSource, I, N - I)
           
           I = InStr(N, PageSource, "Organized by: ") + 14
           N = InStr(I, PageSource, "<")
           Organizer = Mid(PageSource, I, N - I)
           
           Data(Cnt, 0) = Website
           Data(Cnt, 1) = Organizer
        Else
           Data(Cnt, 0) = Status
           Data(Cnt, 1) = ""
        End If
        Cnt = Cnt + 1
      Next Cell
      
    Rng.Offset(0, 1).Resize(Cnt, 2).Value = Data
    
End Sub

Sincerely,
Leith Ross

EDIT: Looks like either the colon or the word website causes the underlining. I will send a copy to you via email.

Sir please take a look. updated version is giving an error of "invalid call procedure". I have mailed you the sheet