Excel VBA extract url form src or href-CodePudding

I have been working with this code for a while, it leaves only the url in the selected area, removing what is unnecessary, it works correctly but only for one url, if more than one url appears in one cell it will leave only the first one, additionally if the url is linked to another it will interpret it as one url, and the idea is to separate them. I tried modifying the code or using ideas from other scripts, but it didn't work for me. The main thing is to leave only the url in the selected area, each on a new line.

Public Function ExtractURL(ByVal InputVal As String) As String
    
    Dim StartPos As Long
    StartPos = InStr(1, InputVal, "http")
    
    If StartPos > 0 Then
        Dim EndPos As Long
        EndPos = InStr(StartPos   1, InputVal, """")
        
    
        If EndPos > 0 Then
            ExtractURL = Mid$(InputVal, StartPos, EndPos - StartPos)
        End If
    End If
    
End Function

Sub url_change_cell_select()
    Dim RetVal As String
Dim cell As Range
For Each cell In Selection.Cells
    RetVal = ExtractURL(cell.Value)
    If RetVal <> vbNullString Then
        cell.Value = RetVal
    End If
Next cell
    Load KOD
    KOD.Show
End Sub

CodePudding user response：

Extract URLs

The Method

Sub ReplaceWithExtractedURLs()
    
    If Selection Is Nothing Then Exit Sub
    If Not TypeOf Selection Is Range Then Exit Sub
    
    Dim cell As Range
    Dim rURL As String
    
    For Each cell In Selection.Cells
        rURL = ExtractURL(CStr(cell.Value))
        If Len(rURL) > 0 Then cell.Value = rURL
    Next cell
    
    'Load KOD
    'KOD.Show

End Sub

The Function

Function ExtractURL(ByVal InputString As String) As String
    
    Const lYes As String = "http"
    Const rNo As String = """"
    Const Delimiter As String = vbLf
    
    Dim tSubs() As String: tSubs = Split(InputString, lYes)
    
    Dim rString As String, tSub As String, tStr As String
    Dim n As Long, ePos As Long
    
    For n = 1 To UBound(tSubs)
        tSub = tSubs(n)
        ePos = InStr(1, tSub, rNo)
        If ePos = 0 Then tStr = tSub Else tStr = Mid(tSub, 1, ePos - 1)
        rString = rString & lYes & tStr & Delimiter
    Next n
    
    If Len(rString) > 0 Then
        rString = Replace(Left(rString, Len(rString) - Len(Delimiter)), _
            Delimiter & Delimiter, Delimiter)
        ExtractURL = rString
    End If
    
End Function