Skip to main content

AccessTr.neT


Importing Web Page Html Elements Text Using Vba

Importing Web Page Html Elements Text Using Vba

#1
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ı
@benbendedeilem
Son Düzenleme: 11/01/2020, 11:17, Düzenleyen: accessman.
Cevapla
#2
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 Sub

@benbendedeilem
Cevapla
#3
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 Sub

@benbendedeilem
Cevapla
#4
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
@benbendedeilem
Son Düzenleme: 11/01/2020, 10:07, Düzenleyen: accessman.
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da
Task