Sub GetTheText()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim text As String
With CreateObject("internetexplorer.application")
.Navigate sURL
text = .Document.getElementsByClassName("container")(0).outerText
.Quit
End With
ws.Cells(1, 1).Value = text
End Sub
Добрый день,
Выше код, все работает. Но как заполнить ячейки столбца по нахождению всех элементов класса container?
Sub GetTheTextNontainer()
Dim i As Integer
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim text As String
i = 0
Set IE = CreateObject("InternetExplorer.Application"):
On Error Resume Next
'URLs = Range("A1")
IE.Navigate URLs
While IE.busy Or (IE.readyState <> 4): DoEvents: Wend
Sleep 1000
Do While i < 100
text = IE.Document.getElementsByClassName("container cleared")(i).outerText
ws.Cells(i + 1, 1).Value = text
i = i + 1
ws.Cells(1, 2).Value = i
Loop
End Sub
Нужно начинать с 1
Но загрузка, капц, долгая. И в конце выходит с ошибкой. Как определить последний элемент "container" и закончить обработку? Сontainer составное число в текстовом формате, можно ли его как-то разложить по ячейкам?
Наверное не логично каждый цикл грузить вебстраницу...
Привет. Оптимизировал. При выполнении просит заменить данные, как это сделать в автоматическом режиме?
Код
Sub GetTheTextContainer()
Dim i As Integer
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim text As String
i = 0
Set IE = CreateObject("InternetExplorer.Application"):
On Error Resume Next
'URLs = Range("A1")
IE.Navigate URLs
While IE.busy Or (IE.readyState <> 4): DoEvents: Wend
Sleep 1000
Do While i < 100
text = IE.Document.getElementsByClassName("container cleared")(i).outerText
ws.Cells(i + 1, 1).Value = text
i = i + 1
ws.Cells(1, 2).Value = i
Loop
ThisWorkbook.Worksheets("Sheet1").Range("A1:A100").Select
Selection.TextToColumns Destination:=ActiveCell.Offset(0, 3).Range("A1"), _
DataType:=xlDelimited, TextQualifier:=xlNone, ConsecutiveDelimiter:=False _
, Tab:=False, Semicolon:=False, Comma:=False, Space:=True, Other:= _
False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1 _
), Array(6, 1), Array(7, 1)), TrailingMinusNumbers:=True
End Sub
Вопрос о замене данных говорит, скорее всего, о том, что макрос меняет какие-то непустые ячейки. Очистите эти ячейки до применения метода TextToColumns.
вот это выдаст ошибку, если активен не Sheet1 на момент выполнения кода. Потому что невозможно выделить ячейки на неактивном листе. Правильнее было бы так:
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub GetTheTextContainer()
Dim i As Integer
Dim TWW As Worksheet: Set TWW = ThisWorkbook.Worksheets("Sheet1")
Dim text As String
i = 0
TWW.Range("D1:J50").ClearContents
Set IE = CreateObject("InternetExplorer.Application"): ' çàãðóæàåì áðàóçåð Internet Explorer
On Error Resume Next
Adrs = Range("A51") ' óêàçûâàåì àäðåñ ñàéòà (âåá-ñòðàíèöû íàõîäèòñÿ â «A1»), òåêñò êîòîðîé çàãðóæàåì
IE.Navigate Adrs ' çàãðóæàåì ñàéò
While IE.busy Or (IE.readyState <> 4): Sleep 1000: DoEvents: Wend ' æäåì, ïîêà çàãðóçèòñÿ ñòðàíèöà
Sleep 1000
Do While i < 50
text = IE.Document.getElementsByClassName("container")(i).outerText
TWW.Cells(i + 1, 1).Value = text
TWW.Cells(52, 1).Value = i
Sleep 10
i = i + 1
Loop
TWW.Range("A1:A50").TextToColumns Destination:=TWW.Range("D1:J50"), _
DataType:=xlDelimited, TextQualifier:=xlNone, Space:=True, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1 _
), Array(6, 1), Array(7, 1)), TrailingMinusNumbers:=True
Application.DeleteObject ("InternetExplorer.Application")
Application.CutCopyMode = False
End Sub
Такой код получился. Но: 1. Будет ли работать DeleteObject, что-то не пойму, в трее приложения (исправил) висят, и нагрузка на процессор растет. Как очистить память? -РЕШЕНО- 2. Все равно просит подтверждения замены данных, хотя ячейки пустые. -РЕШЕНО- 3. Возможно срау стоит разбивать и ложить в ячейки значения.