Буквально час назад все работало, сейчас вываливается ошибка 80004005, указывает на строку:
Вот весь код (не смотрите на комментарии, я нуб, шляпал из нескольких похожих макросов) Если что файл в приложении. Надеюсь на вашу помощь
| Код |
|---|
Set IE = CreateObject("InternetExplorer.Application")
|
| Код |
|---|
Sub Запуск()
Dim myRegExp As New RegExp ' создаём экземпляр RegExp'a
Dim aMatch As Match ' один из совпавших образцов
Dim colMatches As MatchCollection ' коллекция этих образцов
Dim testString As String ' тестируемая строка
Dim ieDoc As MSHTML.HTMLDocument
Dim objCollectionIf As Object
Dim d, lr1&, k&, i&, j&, a()
With Workbooks("Конкуренты.xls").Sheets("Лист1")
lr1 = .Cells(.Rows.Count, "b").End(xlUp).Row
a = .Range("B3:B" & lr1 + 2).Value
For i = 1 To UBound(a)
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = False
IE.Navigate "http://homes.gilcom.ru/view/" & .Cells(i, 2).Value
While IE.busy Or (IE.readyState <> 4)
DoEvents
Wend
Set ieDoc = IE.Document
'Debug.Print ieDoc.body.outerHTML
'ActiveSheet.Cells(1, 3) = ieDoc.body.outerHTML
testString = ieDoc.body.outerHTML
myRegExp.MultiLine = False ' текст однострочный
myRegExp.Global = True ' будем проходить всю строку
myRegExp.IgnoreCase = True ' игнорируем регистр символов
myRegExp.Pattern = "card__header.(.*)</h2>"
Set colMatches = myRegExp.Execute(testString) ' запускаем!
For Each aMatch In colMatches ' проходим по всей коллекции
Cells(i, 4) = aMatch.SubMatches(0)
Next aMatch
myRegExp.Pattern = "card__address.(.*)</p>"
Set colMatches = myRegExp.Execute(testString) ' запускаем!
For Each aMatch In colMatches ' проходим по всей коллекции
Cells(i, 5) = aMatch.SubMatches(0)
Next aMatch
myRegExp.Pattern = "card__cost.(.*)</p>"
Set colMatches = myRegExp.Execute(testString) ' запускаем!
For Each aMatch In colMatches ' проходим по всей коллекции
Cells(i, 6) = aMatch.SubMatches(0)
Cells(i, 6).Replace What:=" ", Replacement:=" "
Next aMatch
ActiveSheet.Hyperlinks.Add Anchor:=.Cells(i, 3), _
Address:="http://homes.gilcom.ru/view/" & .Cells(i, 2).Value, _
TextToDisplay:="Ссылка на жилком"
Next i
End With
End Sub |
