Private Sub Button_Click()
Dim LR As Long
Dim Tgtrw As Long
' Insert Sheet Copy and return to Active Sheet code here
LR =Range("A" & Rows.Count).end(xlUp).Row
For Tgtrw = 3 to LR
GTWebAccess Tgtrw
Next Tgtrw
' Insert Code to delete copy sheet and save workbook here
End Sub
Sub GTWebAccess(ByVal Tgtrw as Long)
Dim IE As New InternetExplorer
Dim Doc As HTMLDocument
Dim NodeList
Dim Elem
Dim X
'IE.Visible = True
IE.navigate "Find Us=" & Range("A" & Tgtrw).Value
Do
DoEvents
Loop Until IE.readyState = READYSTATE_COMPLETE
Set Doc = IE.document
Application.EnableEvents = False
' Retrieve the Outlet from the h4 tag
Range("B" & Tgtrw).Value = Trim(Doc.getElementsByTagName("h4")(0).innerText)
X = 1
' Retrieve the Paragraph tags
Set NodeList = Doc.getElementsByTagName("p")
For Each Elem In NodeList
'
' The Paragraph info is located in paragraphs 1 through 6
' 1 and 2 contain the Address
' 3 and 4 contain the Telephone
' 5 and 6 contain the E-mail
Select Case X
Case Is = 2
If Elem.innerText = "Just fill in your details" Then
Range("B" & Tgtrw).Value = "Please enter a valid Post Code"
Application.EnableEvents = True
IE.Quit
Set IE = Nothing
Exit Sub
Else
Range("C" & Tgtrw).Value = Elem.innerText
End If
Case Is = 4
Range("D" & Tgtrw).Value = Elem.innerText
Case Is = 6
Range("E" & Tgtrw).Value = Elem.innerText
End Select
X = X + 1
Next Elem
Application.EnableEvents = True
IE.Quit
Set IE = Nothing
' Set columns B through E column width to 32
Columns("B:E").ColumnWidth =32
End Sub