Excel VBA Macro: очистка данных из таблицы сайта, которая охватывает несколько страниц

Question

Заранее спасибо за помощь. Я запускаю Windows 8.1, у меня есть последние браузеры IE/Chrome и последний Excel. Я пытаюсь написать макрос Excel, который извлекает данные из StackOverflow (https://stackoverflow.com/tags). В частности, я пытаюсь вывести дату (что выполняется макрос), имена тегов, # тегов и краткое описание того, что такое тег. У меня он работает для первой страницы таблицы, но не для остальных (сейчас на данный момент 1132 страницы). Прямо сейчас, он перезаписывает данные каждый раз, когда я запускаю макрос, и я не уверен, как заставить его искать следующую пустую ячейку перед запуском. Наконец, я пытаюсь запустить ее автоматически один раз в неделю.

Я бы очень признателен за любую помощь здесь. Проблемы:

1. вытягивать данные из веб-таблицы за пределы первой страницы
2. делает его царапать данные в следующую пустую строку, а не перезаписывать
3. Создание макросов автоматически запускать один раз в неделю

Код (пока) приведен ниже. Благодаря!

Enum READYSTATE 
READYSTATE_UNINITIALIZED = 0 
READYSTATE_LOADING = 1 
READYSTATE_LOADED = 2 
READYSTATE_INTERACTIVE = 3 
READYSTATE_COMPLETE = 4 
End Enum 

Sub ImportStackOverflowData() 
    'to refer to the running copy of Internet Explorer 
    Dim ie As InternetExplorer 
    'to refer to the HTML document returned 
    Dim html As HTMLDocument 
    'open Internet Explorer in memory, and go to website 
    Set ie = New InternetExplorer 
    ie.Visible = False 
    ie.navigate "http://stackoverflow.com/tags" 

    'Wait until IE is done loading page 
    Do While ie.READYSTATE <> READYSTATE_COMPLETE 
    Application.StatusBar = "Trying to go to StackOverflow ..." 
    DoEvents 
    Loop 

    'show text of HTML document returned 
    Set html = ie.document 

    'close down IE and reset status bar 
    Set ie = Nothing 
    Application.StatusBar = "" 

    'clear old data out and put titles in 
    'Cells.Clear 
    'put heading across the top of row 3 
    Range("A3").Value = "Date Pulled" 
    Range("B3").Value = "Keyword" 
    Range("C3").Value = "# Of Tags" 
    'Range("C3").Value = "Asked This Week" 
    Range("D3").Value = "Description" 

    Dim TagList As IHTMLElement 
    Dim Tags As IHTMLElementCollection 
    Dim Tag As IHTMLElement 
    Dim RowNumber As Long 
    Dim TagFields As IHTMLElementCollection 
    Dim TagField As IHTMLElement 
    Dim Keyword As String 
    Dim NumberOfTags As String 
    'Dim AskedThisWeek As String 
    Dim TagDescription As String 
    'Dim QuestionFieldLinks As IHTMLElementCollection 
    Dim TodaysDate As Date 

    Set TagList = html.getElementById("tags-browser") 
    Set Tags = html.getElementsByClassName("tag-cell") 
    RowNumber = 4 

    For Each Tag In Tags 
    'if this is the tag containing the details, process it 
    If Tag.className = "tag-cell" Then 
     'get a list of all of the parts of this question, 
     'and loop over them 
     Set TagFields = Tag.all 

     For Each TagField In TagFields 
     'if this is the keyword, store it 
     If TagField.className = "post-tag" Then 
      'store the text value 
      Keyword = TagField.innerText 
      Cells(RowNumber, 2).Value = TagField.innerText 
     End If 

     If TagField.className = "item-multiplier-count" Then 
      'store the integer for number of tags 
      NumberOfTags = TagField.innerText 
      'NumberOfTags = Replace(NumberOfTags, "x", "") 
      Cells(RowNumber, 3).Value = Trim(NumberOfTags) 
     End If 

     If TagField.className = "excerpt" Then 
      Description = TagField.innerText 
      Cells(RowNumber, 4).Value = TagField.innerText 
     End If 

     TodaysDate = Format(Now, "MM/dd/yy") 
     Cells(RowNumber, 1).Value = TodaysDate 

     Next TagField 

     'go on to next row of worksheet 
     RowNumber = RowNumber + 1 
    End If 
    Next 

    Set html = Nothing 

    'do some final formatting 
    Range("A3").CurrentRegion.WrapText = False 
    Range("A3").CurrentRegion.EntireColumn.AutoFit 
    Range("A1:C1").EntireColumn.HorizontalAlignment = xlCenter 
    Range("A1:D1").Merge 
    Range("A1").Value = "StackOverflow Tag Trends" 
    Range("A1").Font.Bold = True 
    Application.StatusBar = "" 
    MsgBox "Done!" 
End Sub 

Answer 1

Нет необходимости очищать переполнение стека, когда они делают доступными данные для вас такими вещами, как Проводник данных. С помощью этого запроса в проводнике данных должны получить результаты вам нужно:

select t.TagName, t.Count, p.Body 
from Tags t inner join Posts p 
on t.ExcerptPostId = p.Id 
order by t.count desc; 

постоянную ссылку на этот запрос является here и опция «Загрузить CSV», который появляется после запуска запроса, вероятно, самый простой способ, чтобы получить данных в Excel. Если вы хотите автоматизировать эту часть вещей, прямая ссылка на результаты загрузки CSV равна here

Answer 2

Я не использую DOM, но мне очень легко обойти только поиск между известными тегами. Если когда-либо выражения, которые вы ищете, слишком распространены, просто немного измените код, чтобы он искал строку после строки).

Пример:

Public Sub ZipLookUp() 
Dim URL As String, xmlHTTP As Object, html As Object, htmlResponse As String 
Dim SStr As String, EStr As String, EndS As Integer, StartS As Integer 
Dim Zip4Digit As String 

    URL = "https://tools.usps.com/go/ZipLookupResultsAction!input.action?resultMode=1&companyName=&address1=1642+Harmon+Street&address2=&city=Berkeley&state=CA&urbanCode=&postalCode=&zip=94703" 
    Set xmlHTTP = CreateObject("MSXML2.XMLHTTP") 
    xmlHTTP.Open "GET", URL, False 
    On Error GoTo NoConnect 
    xmlHTTP.send 
    On Error GoTo 0 
    Set html = CreateObject("htmlfile") 
    htmlResponse = xmlHTTP.ResponseText 
    If htmlResponse = Null Then 
     MsgBox ("Aborted Run - HTML response was null") 
     Application.ScreenUpdating = True 
     GoTo End_Prog 
    End If 

    'Searching for a string within 2 strings 
    SStr = "<span class=""address1 range"">" ' first string 
    EStr = "</span><br />"     ' second string 
    StartS = InStr(1, htmlResponse, SStr, vbTextCompare) + Len(SStr) 
    EndS = InStr(StartS, htmlResponse, EStr, vbTextCompare) 
    Zip4Digit = Left(Mid(htmlResponse, StartS, EndS - StartS), 4) 

    MsgBox Zip4Digit 

GoTo End_Prog 
NoConnect: 
    If Err = -2147467259 Or Err = -2146697211 Then MsgBox "Error - No Connection": GoTo End_Prog 'MsgBox Err & ": " & Error(Err) 
End_Prog: 
End Sub