Quantcast
Channel: Active questions tagged excel - Stack Overflow
Viewing all articles
Browse latest Browse all 88854

I'm getting stuck at vba runtime error 424

$
0
0

I'm getting

run-time error 424

and I don't know how to fix it.

My previous question I posted ; How to scrape specific part of online english dictionary?

My final goal is to get result like this;

    A          B
beginning   bɪˈɡɪnɪŋ
behalf      bɪˈhæf
behave      bɪˈheɪv
behaviour   bɪˈheɪvjər
belong      bɪˈlɔːŋ
below       bɪˈloʊ
bird        bɜːrd
biscuit     ˈbɪskɪt

Here's code I wrote, and it's mostly based on someone else's code I found on internet.

'   Microsoft ActiveX Data Objects x.x Library
'   Microsoft XML, v3.0
'   Microsoft VBScript Regular Expressions

Sub ParseHelp()

    ' Word reference from
    Dim Url As String
    Url = "https://www.oxfordlearnersdictionaries.com/definition/english/"& Cells(ActiveCell.Row, "B").Value

    ' Get dictionary's html
    Dim Html As String
    Html = GetHtml(Url)

    ' Check error
    If InStr(Html, "<TITLE>Not Found</Title>") > 0 Then
        MsgBox "404"
        Exit Sub
    End If

    ' Extract phonetic alphabet from HTML
    Dim wrapPattern As String
    wrapPattern = "<span class='name' (.*?)</span>"
    Set wrapCollection = FindRegexpMatch(Html, wrapPattern)
    ' MsgBox StripHtml(CStr(wrapCollection(1)))

    ' Fill phonetic alphabet into cell
    If Not wrapCollection Is Nothing Then
        Dim wrap As String

        On Error Resume Next
            wrap = StripHtml(CStr(wrapCollection(1)))
        If Err.Number <> 0 Then
            wrap = ""
        End If
        Cells(ActiveCell.Row, "C").Value = wrap
    Else
        MsgBox "not found"
    End If

End Sub

Public Function StripHtml(Html As String) As String
    Dim RegEx As New RegExp
    Dim sOut As String

    Html = Replace(Html, "</li>", vbNewLine)
    Html = Replace(Html, "&nbsp;", "")

    With RegEx
        .Global = True
        .IgnoreCase = True
        .MultiLine = True
        .Pattern = "<[^>]+>"
    End With

    sOut = RegEx.Replace(Html, "")
    StripHtml = sOut
    Set RegEx = Nothing
End Function

Public Function GetHtml(Url As String) As String
    Dim xmlhttp As Object
    Set xmlhttp = CreateObject("MSXML2.serverXMLHTTP")
    Dim converter As New ADODB.stream

    ' Get
    request.Open "GET", Url, False
    request.send

    ' raw bytes
    converter.Open
    converter.Type = adTypeBinary
    converter.Write request.responseBody

    ' read
    converter.Position = 0
    converter.Type = adTypeText
    converter.Charset = "utf-8"' close
    GetHtml = converter.ReadText
    converter.Close

End Function

Public Function FindRegexpMatch(txt As String, pat As String) As Collection
    Set FindRegexpMatch = New Collection

    Dim rx As New RegExp
    Dim matcol As MatchCollection
    Dim mat As Match
    Dim ret As String
    Dim delimiter As String

    txt = Replace(txt, Chr(10), "")
    txt = Replace(txt, Chr(13), "")

    rx.Global = True
    rx.IgnoreCase = True
    rx.MultiLine = True
    rx.Pattern = pat
    Set matcol = rx.Execute(txt)
    'MsgBox "Match:"& matcol.Count

    On Error GoTo ErrorHandler
    For Each mat In matcol
        'FindRegexpMatch.Add mat.SubMatches(0)
        FindRegexpMatch.Add mat.Value

    Next mat
    Set rx = Nothing


   ' Insert code that might generate an error here
   Exit Function
ErrorHandler:
   ' Insert code to handle the error here
   MsgBox "FindRegexpMatch. "& Err.GetException()
   Resume Next

End Function

Any kind of help would be greatly appreciated.


Viewing all articles
Browse latest Browse all 88854


<script src="https://jsc.adskeeper.com/r/s/rssing.com.1596347.js" async> </script>