+- AccessTr.neT (https://accesstr.net)
+-- Forum: AccessTr.neT Genel (https://accesstr.net/forum-accesstr-net-genel.html)
+--- Forum: Çöp Kutusu (https://accesstr.net/forum-cop-kutusu.html)
+--- Konu Başlığı: Importing Web Page Html Elements Text Using Vba (/konu-importing-web-page-html-elements-text-using-vba.html)
Importing Web Page Html Elements Text Using Vba - accessman - 11/01/2020
Eklediğim kodlarda Excel sayfası değişince webden bilgi alıyor nasıl kullanıldığını anlayamadım yardımcı olacak arkadaş var mı
Cvp: Importing Web Page Html Elements Text Using Vba - accessman - 11/01/2020
Kod:
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 SubCvp: Importing Web Page Html Elements Text Using Vba - accessman - 11/01/2020
Kod:
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 SubCvp: Importing Web Page Html Elements Text Using Vba - accessman - 11/01/2020
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Tgtrw As Long
Tgtrw = Target.Row
If Target.Row = Range("A" & Tgtrw).Row And Target.Column = Range("A" & Tgtrw).Column Then
Dim IE As New InternetExplorer
'IE.Visible = True
IE.navigate "gothere.sg/maps#q:"
'& Range("A" & Tgtrw).Value
Do
DoEvents
Loop Until IE.readyState = READYSTATE_COMPLETE
'Dim Doc As HTMLDocument
Set Doc = IE.document
' Dim sDD As String
Doc.getElementById("q").Value = Range("A" & Tgtrw).Value
Doc.getElementById("ss").Click
sDD = Trim(Application.WorksheetFunction.Substitute(Doc.getElementById("panel").getElementsByClassName("place")(0).getElementsByClassName("locf")(0).innerText, "Singapore " & Range("A" & Tgtrw).Value, ""))
IE.Quit
' Dim aDD As Variant
aDD = Split(sDD, " ")
Range("B" & Tgtrw).Value = Left(sDD, Application.WorksheetFunction.Find(" ", sDD) - 1)
Range("C" & Tgtrw).Value = Right(sDD, Len(sDD) - Application.WorksheetFunction.Find(" ", sDD))
End If
End Sub