K.K. K.K. - 5 months ago 32
HTML Question

VBA HTML Data Scrape Guidance

I'm attempting to extract data from the following site using VBA, by inputting a city, and having selected results outputted into excel cells. I'm very new to this, and this my third attempt, but now I'm getting a "Object Required" error when I try to run it. I've stepped through it, and it throws the error at, of course, the IE object I tried to create. Any suggestions on what I can do to tweak my code? Any help would be much appreciated! Thank you.

Code



Private Sub CreditUnion()

If Target.Row = Range("City").Row And Target.Column = Range("City").Column Then

Dim IE As Object

Set IE = CreateObject("internetexplorer.application")


IE.Navigate "http://mapping.ncua.gov/SingleResult.aspx"
IE.Visible = False

Do While IE.Busy

DoEvents

Loop

Set TableResults = IE.document.getElementsByID("MainContent_newDetails")

Dim City As String: City = TableResults.Cells(17).innerHTML
Dim CreditUnion As String: CreditUnion = TableResults.Cells(0).innerHTML
Dim Region As String: Region = TableResults.Cells(9).innerHTML
Dim Status As String: Status = TableResults.Cells(3).innerHTML
Dim Assets As String: Assets = TableResults.Cells(13).innerHTML
Dim Members As String: Members = TableResults.Cells(15).innerHTML


Range("B1").Value = City
Range("C4").Value = CreditUnion
Range("D4").Value = Region
Range("E4").Value = Status
Range("F4").Value = Assets
Range("G4").Value = Members


IE.Quit
Set IE = Nothing

End If

End Sub

pcw pcw
Answer

I take New York for example, the code as below.

Private Sub CreditUnion()
Dim IE As Object, TableResults As Object, webRow As Object, charterInfo As Variant, page 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
    DoEvents
Loop

'input city name into form
IE.document.getelementbyid("MainContent_txtCity").Value = "new york"
'click find button
IE.document.getelementbyid("MainContent_btnFind").Click


Do
    DoEvents

    'wait 5 sec. for screen refresh
    beginTime = Now
    Application.Wait (Now + TimeValue("00:00:05"))
    With IE.document.getelementbyid("MainContent_grid")
        For r = 1 To .Rows.Length - 1
            If Not IsArray(charterInfo) Then
                ReDim charterInfo(5, 0) As Variant
            Else
                ReDim Preserve charterInfo(5, UBound(charterInfo, 2) + 1) As Variant
            End If

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

    'check if final page, if not click "next page"
    page = IE.document.getelementbyid("MainContent_pager_to").innertext
    If page < IE.document.getelementbyid("MainContent_pager_total").innertext Then IE.document.getelementbyid("MainContent_pageNext").Click
Loop Until page = IE.document.getelementbyid("MainContent_pager_total").innertext

For r = 0 To UBound(charterInfo, 2)
    IE.navigate "http://mapping.ncua.gov/SingleResult.aspx?ID=" & charterInfo(0, r)
    Do While IE.Busy
        DoEvents
    Loop
    'wait 5 sec. for screen refresh
    beginTime = Now
    Application.Wait beginTime + TimeValue("0:00:05")

    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, ",", "")
            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
Comments