How to copy URL from specific cell using VBA - excel

Question

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.

Answer 1

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