CODEWITHSUNDEEP
excelvbaexcel-formula
Kalpesh Koli
Kalpesh Koli

Reputation: 87

How to copy URL from specific cell using VBA

I need your help to get URL from a specific cell. For an example assume the below is the cell data I am referring to.

Microsoft Teams meeting

Join on your computer or mobile app

Click here to join the meeting https://teams.microsoft.com/l/meetup-join/19%3ameeting_OWEzN2JmZmEtOTVmMS00ZDc4LThlNzQtNjQyNWM0ZjllODIx%40thread.v2/0?context=%7c%22Tid%22%3a%227a916015-20ae-4ad1-9170-eafd915e9272%22%2c%24Oid%22%3a%22b8ed972c-91b4-4fe1-a5d5-1410ea30a159%22%7d

Learn More https://aka.ms/JoinTeamsMeeting | Meeting options https://teams.microsoft.com/meetingOptions/?organizerId=b8ed972c-79b4-4fe1-a5d5-1410ea30a159&tenantId=7a916015-20ae-4ad1-9170-eefd915e9272&threadId=19_meeting_OWEzN2JmZmEtOTVmMS00ZDc4LThlNzQtNjQyNWM0ZjllODIx@thread.v2&messageId=0&language=en-US

So from above cell text i want to copy the first URL to another cell. Request your guidance.

Upvotes: 0

Views: 183

Answers (1)

FaneDuru
FaneDuru

Reputation: 42256

Please, try the next function:

Function extractURLs(strCell As String) As Variant
    Dim frst As Long, lst As Long, arr, k As Long, sp As Long
    Dim pos As Long, URLNo As Long, i As Long
    
    'count existing number if URLs:
    Do
       pos = InStr(pos + 1, strCell, "https:")
       If pos > 0 Then
            URLNo = URLNo + 1
        End If
    Loop While pos > 0
    If URLNo = 0 Then extractURLs = Array("Error"): Exit Function 'in case of  no URL being found
    ReDim arr(URLNo - 1) 'ReDim the array to keep the found URLs
    For i = 1 To URLNo    'loop between the above occurrences found number
        frst = InStr(frst + 1, strCell, "https:")            'determine the first occurrence for https: string
        lst = InStr(frst, strCell, vbLf)                       'determine the last occurrence (starting from frst) for end of line
        If lst > 0 Then                                         'if the string is found:
            sp = InStr(Mid(strCell, frst, lst - frst), " ")  'determine if a space exists in the string between first and last
            If sp > 0 Then                                     'if it exists:
                arr(k) = Mid(strCell, frst, sp): k = k + 1 'it returns the string up to the first space
            Else
                arr(k) = Mid(strCell, frst, lst - frst): k = k + 1 'if returns the string up to the end of line
            End If
        End If
    Next i
     extractURLs = arr   'return the array content
End Function

It can be tested like in such a code:

Sub testExtractURLs()
   Dim strTest As String, arr, i As Long
   strTest = ActiveCell.value
   arr = extractURLs(strTest)
   If UBound(arr) = 0 Then
        If arr(0) = "Error" Then
            MsgBox "No any URL could be found..."
        Else
            Debug.Print arr(0)
        End If
  Else
        For i = 0 To UBound(arr)
             Debug.Print arr(i)
        Next i
  End If
End Sub

Please, test it and send some feedback

Upvotes: 2

Related Questions