ошибка при вызове функции для извлечения всех совпадений регулярных выражений "ошибка времени выполнения" 1004 ": ошибка приложения или объекта"

Question

Я пытаюсь извлечь все совпадения регулярных выражений из списка URL-адресов, начиная с A2, до "LastRow" и поместить все совпадения, разделенные запятой, в столбце C.

Я ссылаюсь на функцию "regexexicute ", и каждый раз, когда я запускаю код, я получаю:

"run-time error '1004': Application-defined or object defined error"

Когда я нажимаю отладку, эта строка выделяется желтым цветом:

"ActiveCell.Offset(0, 2).Value = RegexExecute(str, "url.*?(\/products\/.*?).>", False)"

Ниже приведен код VBA Iпытаюсь запустить, и ниже этой функции она вызывает:

Sub Scrape_all_matches_by regex()

'Start Callouts
    Dim navtar As String
    Dim oHTTP As Object
    Dim str As String
    Dim reg As String
    'Dim body As String
    Dim sht As Worksheet
    Dim LastRow As Long
    Dim cell As Range
    Dim DataRange As Range
    Set sht = ActiveSheet
    Set oHTTP = CreateObject("msxml2.ServerXMLHTTP")
    LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
'End callouts

'Start- Find Last Row & Do stuff to all cells between first &  last row
    Set DataRange = Range("A2:A" & LastRow)
    For Each cell In DataRange
        cell.Activate
        navtar = Replace(Replace(Replace(ActiveCell.Value, "https://", ""), "http://", ""), "www.", "") 'Clean URL
        navtar = "http://" & navtar
        'On Error GoTo HTTPErr:
        oHTTP.Open "GET", navtar, False
        oHTTP.send
        str = (oHTTP.responseText)

'Start- Do stuff to all cells between first &  last row
         ActiveCell.Offset(0, 2).Value = RegexExecute(str, "url.*?(\/products\/.*?).>", False)
'End- Do stuff to all cells between first &  last row

LoopPickup:
        Next
'End- Find Last Row & Do stuff to all cells between first &  last row
        MsgBox "Done"
        Exit Sub
'Start- URL error handeling
HTTPErr:
        If Err.Number <> 0 Then
        ActiveCell.Offset(0, 1).Value = "Error: " & Err.Description
        End If
        Resume LoopPickup
'end- URL error handeling

End Sub

Function RegexExecute(str As String, reg As String, Optional findOnlyFirstMatch As Boolean = False) As Object
'Executes a Regular Expression on a provided string and returns all matches
'str - string to execute the regex on
'reg - the regular expression
    Dim Regex As Object
    Set Regex = CreateObject("VBScript.RegExp"): Regex.Pattern = reg
    Regex.Global = Not (findOnlyFirstMatch)
    If Regex.Test(str) Then
        Set RegexExecute = Regex.Execute(str)
        Exit Function
    End If
End Function

Обновление решено - мне удалось заменить RegexExecute на метод RegexExtract, упомянутый в этом [Ответ] какпредложил в комментариях Matt.G 51. Спасибо.

Answer 1

Обновление.Решено - мне удалось заменить RegexExecute на RegexExtract метод, упомянутый в этом [Ответ] , как это предлагается в комментариях Matt.G 51. Спасибо.