VBA如何抓取html标题,VBA HTML数据抓取指南

我以纽约为例，代码如下。

我在2016/6/7重写

Public Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)

Sub CreditUnion()

Dim IE As Object, TableResults As Object, webRow As Object, charterInfo As Variant, page As Long, pageTotal As Long, r As Long

Dim beginTime As Date, i As Long

Set IE = CreateObject("internetexplorer.application")

IE.navigate "http://mapping.ncua.gov/ResearchCreditUnion.aspx"

IE.Visible = True

Do While IE.Busy Or IE.readystate <> 4 '4 = READYSTATE_COMPLETE

DoEvents

Loop

'input city name into form

IE.document.getelementbyid("MainContent_txtCity").Value = "new york"

'click find button

IE.document.getelementbyid("MainContent_btnFind").Click

sleep 5 * 1000

'total pages

pageTotal = IE.document.getelementbyid("MainContent_pager_total").innertext

page = 0

Do Until page = pageTotal

DoEvents

page = IE.document.getelementbyid("MainContent_pager_to").innertext

With IE.document.getelementbyid("MainContent_grid")

For r = 1 To .Rows.Length - 1

If Not IsArray(charterInfo) Then

ReDim charterInfo(7, 0) As Variant

Else

ReDim Preserve charterInfo(7, UBound(charterInfo, 2) + 1) As Variant

End If

charterInfo(0, UBound(charterInfo, 2)) = .Rows(r).Cells(0).innertext

Next r

End With

If page < pageTotal Then

IE.document.getelementbyid("MainContent_pageNext").Click

beginTime = Now

Application.Wait (Now + TimeValue("00:00:05"))

End If

Loop

For r = 0 To UBound(charterInfo, 2)

IE.navigate "http://mapping.ncua.gov/SingleResult.aspx?ID=" & charterInfo(0, r)

Do While IE.Busy Or IE.readystate <> 4 '4 = READYSTATE_COMPLETE

DoEvents

Loop

'wait 5 sec. for screen refresh

sleep 5 * 1000

With IE.document.getelementbyid("MainContent_newDetails")

For i = 0 To .Rows.Length - 1

DoEvents

Select Case .Rows(i).Cells(0).innertext

Case "Credit Union Name:"

charterInfo(1, r) = .Rows(i).Cells(1).innertext

Case "Region:"

charterInfo(2, r) = .Rows(i).Cells(1).innertext

Case "Credit Union Status:"

charterInfo(3, r) = .Rows(i).Cells(1).innertext

Case "Assets:"

charterInfo(4, r) = Replace(Replace(.Rows(i).Cells(1).innertext, ",", ""), "$", "")

Case "Number of Members:"

charterInfo(5, r) = Replace(.Rows(i).Cells(1).innertext, ",", "")

Case "Address:"

charterInfo(6, r) = .Rows(i).Cells(1).innertext

Case "Phone:"

charterInfo(7, r) = "'" & .Rows(i).Cells(1).innertext

End Select

Next i

End With

Next r

IE.Quit

Set IE = Nothing

'post result on Excel cell

Worksheets(1).Range("A1").Resize(UBound(charterInfo, 2) + 1, UBound(charterInfo, 1) + 1).Value = Application.Transpose(charterInfo)

End Sub