Outline:
Два метода. Один без открытия браузера, выдающий XMLHTTP запрос , другой с помощью Internet Explorer.
Если есть API-способ сделать это, я бы с этим определенно согласился. Следующие 2 метода в настоящее время работают для всех отображаемых вами URL.
Примечание:
Они основаны на конечной части URL на листе, то есть на имени человека. Смотрите изображение внизу.
XMLHTTP-запрос:
Используется пользовательский класс clsHTTP для хранения XMLHTTP object. Есть 2 метода. Один, GetString, выдать запрос и разобрать часть ответа. Другой, GetInfo, чтобы взять строку, возвращаемую GetString, проанализировать интересующие элементы и вернуть их в массив.
TODO:
Класс может быть разработан. Это голые кости. В частности, это может быть сделано с обработкой ошибок, добавленной, например, для обработки потери соединения с сервером.
VBA:
Класс clsHTTP:
Option Explicit
Private http As Object
Private Sub Class_Initialize()
Set http = CreateObject("MSXML2.XMLHTTP")
End Sub
Public Function GetString(ByVal URL As String) As String
Dim sResponse As String
With http
.Open "GET", URL, False
.send
sResponse = StrConv(.responseBody, vbUnicode)
GetString = Split(Split(sResponse, "ProfilePage"":")(1), "comments_disabled")(0)
End With
End Function
Public Function GetInfo(ByVal sResponse As String) As Variant
Dim results(0 To 4)
'Name, Followers, Following,Posts,Biography
On Error Resume Next
results(0) = Split(sResponse, """full_name"":""")(1)
results(1) = Split(Split(sResponse, """count"":")(1), "}")(0)
results(2) = Split(Split(sResponse, """count"":")(2), "}")(0)
results(3) = Split(Split(sResponse, """count"":")(4), ",")(0)
results(4) = Split(Split(sResponse, """biography"":""")(1), """,")(0)
On Error GoTo 0
GetInfo = results
End Function
Стандартный модуль module 1:
Option Explicit
Public Sub GetInfo()
Dim http As clsHTTP, sResponse As String, lastRow As Long, groupResults()
Set http = New clsHTTP
Const BASE_URL As String = "https://www.instagram.com/"
With ThisWorkbook.Worksheets("Sheet1")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Select Case lastRow
Case 1
Exit Sub
Case 2
ReDim arr(1, 1): arr(1, 1) = .Range("A2").Value
Case Else
arr = .Range("A2:A" & lastRow).Value
End Select
ReDim groupResults(0 To lastRow - 2)
Dim results(0 To 4), counter As Long, i As Long
With http
For i = LBound(arr, 1) To UBound(arr, 1)
If Len(BASE_URL & arr(i, 1)) > Len(BASE_URL) Then
sResponse = .GetString(BASE_URL & arr(i, 1))
groupResults(counter) = .GetInfo(sResponse)
sResponse = vbNullString
counter = counter + 1
End If
Next
End With
For i = LBound(groupResults) To UBound(groupResults)
.Cells(2 + i, "B").Resize(1, UBound(results) + 1) = groupResults(i)
Next
End With
End Sub
Internet Explorer:
Я напишу что-нибудь получше чуть позже, но ниже помещается цикл внутри того места, где вы создали объект Internet Explorer, чтобы вы не продолжали создавать и разрушать. Он вводит ожидания присутствия элементов, а также загрузки страницы.
TODO:
Некоторые первоначальные изменения, которые я бы сделал:
- Рефакторинг кода, чтобы иметь отдельные функции / подпрограммы, которые обрабатывают извлечение данных;
- Добавьте методы управления ошибочными соединениями / тайм-аутами.
VBA:
Option Explicit
Public Sub GetInfo()
Dim IE As New InternetExplorer, lastRow As Long, arr(), groupResults()
Const BASE_URL As String = "https://www.instagram.com/"
With ThisWorkbook.Worksheets("Sheet1")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Select Case lastRow
Case 1
Exit Sub
Case 2
ReDim arr(1, 1): arr(1, 1) = .Range("A2").Value
Case Else
arr = .Range("A2:A" & lastRow).Value
End Select
ReDim groupResults(0 To lastRow - 2)
Dim results(0 To 4), counter As Long, i As Long
With IE
.Visible = True
For i = LBound(arr, 1) To UBound(arr, 1)
If Len(BASE_URL & arr(i, 1)) > Len(BASE_URL) Then
.navigate BASE_URL & arr(i, 1)
While .Busy Or .readyState < 4: DoEvents: Wend
'Name, Followers, Following,Posts,Biography
Dim aNodeList As Object, ele As Object, t As Date
Const MAX_WAIT_SEC As Long = 5
t = Timer
Do
DoEvents
On Error Resume Next
Set ele = .document.querySelector(".rhpdm")
On Error GoTo 0
If Timer - t > MAX_WAIT_SEC Then Exit Do
Loop While ele Is Nothing
' Application.Wait Now + TimeSerial(0, 0, 2)
results(0) = ele.innerText
Set aNodeList = .document.querySelectorAll(".g47SY")
results(1) = aNodeList.item(0).innerText
results(2) = aNodeList.item(1).innerText
results(3) = aNodeList.item(2).innerText
results(4) = .document.querySelector(".rhpdm ~ span").innerText
Set aNodeList = Nothing : Set ele = Nothing
groupResults(counter) = results
counter = counter + 1
End If
Next
.Quit '<== Remember to quit application
End With
For i = LBound(groupResults) To UBound(groupResults)
.Cells(2 + i, "B").Resize(1, UBound(results) + 1) = groupResults(i)
Next
End With
End Sub
Результаты:
