• Foruma hoş geldin 👋 Ziyaretçi

    Forum içeriğine ve tüm hizmetlerimize erişim sağlamak için foruma kayıt olmalı ya da giriş yapmalısınız. Foruma üye olmak tamamen ücretsizdir.

    Giriş yap veya Şimdi kayıt ol

Çözüldü IP Sorgula Formülünü Butona Atama

Bu konu çözüldü olarak işaretlenmiştir. Çözülmediğini düşünüyorsanız konuyu rapor edebilirsiniz.
Durum
Konu Çözümlendiği İçin Kapatılmıştır.
O

odemirci113

Yeni Üye
Katılım
11 Kas 2022
Mesajlar
3
Aldığı beğeni
0
Excel V
Office 2016 TR
Merhaba,

Kod: 
Public Function Haluk_Ip(ipAddress)
    'Haluk - 15/11/2019
    'E-posta: sa4truss@Link ve Reklam İçerikli Paylaşımlar Engellenme Sebebidir.
    '
    Dim strURL As String, XDoc As Object

    Set XDoc = CreateObject("MSXML2.DOMDocument")
    XDoc.async = False
    XDoc.validateOnParse = False

    strURL = "http://ip-api.com/xml/" & ipAddress
    XDoc.Load strURL

    myIP = XDoc.SelectSingleNode("query/query").Text
    myCountry = XDoc.SelectSingleNode("query/country").Text
    myRegion = XDoc.SelectSingleNode("query/regionName").Text
    myCity = XDoc.SelectSingleNode("query/city").Text

  
Haluk_Ip = myRegion

    Set XDoc = Nothing
End Function

Merhaba, yukarıda belirtilen formülü bir butona atamak istiyorum. Butona tıkladığımda A2 hücresindeki IP adresini B2 hücresi boş ise yazmasını, boş değilse hiç bir işlem yapmamasını, bu işlemi dolu olan son A hücresine kadar yapmasını istiyorum. Nasıl yapacağım konusunda yardımcı olabilir misiniz? Şimdiden Çok teşekkür ederim.
 
Çözüm
Ali ÖZ
Kod: 
Private Sub CommandButton1_Click()
    Dim strURL As String, XDoc As Object
    for i = 2 to range("a65536").end(3).row
    ipAddress = Range("A" & i).Value
    Set XDoc = CreateObject("MSXML2.DOMDocument")
    XDoc.async = False
    XDoc.validateOnParse = False

    strURL = "http://ip-api.com/xml/" & ipAddress
    XDoc.Load strURL

    myIP = XDoc.SelectSingleNode("query/query").Text
    myCountry = XDoc.SelectSingleNode("query/country").Text
    myRegion = XDoc.SelectSingleNode("query/regionName").Text
    myCity = XDoc.SelectSingleNode("query/city").Text

   range("b" & i).value = myRegion
   next

    Set XDoc = Nothing
End Sub
Tarihe göre sırala Oylara göre sırala
Deneyin.
Kod: 
Private Sub CommandButton1_Click()
    Dim strURL As String, XDoc As Object
    ipAddress = Range("A2").Value
    Set XDoc = CreateObject("MSXML2.DOMDocument")
    XDoc.async = False
    XDoc.validateOnParse = False

    strURL = "http://ip-api.com/xml/" & ipAddress
    XDoc.Load strURL

    myIP = XDoc.SelectSingleNode("query/query").Text
    myCountry = XDoc.SelectSingleNode("query/country").Text
    myRegion = XDoc.SelectSingleNode("query/regionName").Text
    myCity = XDoc.SelectSingleNode("query/city").Text


   MsgBox (myRegion)

    Set XDoc = Nothing
End Sub
 
Olumlu oy 0 Negatif oyla
Ali ÖZ' Alıntı:
Deneyin.
Kod: 
Private Sub CommandButton1_Click()
    Dim strURL As String, XDoc As Object
    ipAddress = Range("A2").Value
    Set XDoc = CreateObject("MSXML2.DOMDocument")
    XDoc.async = False
    XDoc.validateOnParse = False

    strURL = "http://ip-api.com/xml/" & ipAddress
    XDoc.Load strURL

    myIP = XDoc.SelectSingleNode("query/query").Text
    myCountry = XDoc.SelectSingleNode("query/country").Text
    myRegion = XDoc.SelectSingleNode("query/regionName").Text
    myCity = XDoc.SelectSingleNode("query/city").Text


   MsgBox (myRegion)

    Set XDoc = Nothing
End Sub
Genişletmek için tıkla...
emeğiniz için teşekkür ederim yalnız ben sonucu mesaj kutusunda göstermesini değil, B2 hücresi boşsa oraya yazdırmasını B2 hücresi doluysa bir alt sekmeden işleme devam etmesini istedim. Daha önce başka bir arkadaşımın hazırladığı, ancak site kullanım dışı olduğu için çalışmayan buton kodunu paylaşıyorum. belki üzerinde düzeltme yapmak daha kolay olur.

Kod: 
        Select Case site
            Case "ipbak"
            With xhr
                .Open "POST", "http://ipbak.com/ip-sorgulama.php", False
                .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
                .send ("query_ip=" & Sayfa1.Cells(Satır.Row, 2).Value & "&submit=")
                If .readyState = 4 And .Status = 200 Then
                    Set doc = New MSHTML.HTMLDocument
                    doc.body.innerHTML = .responseText
                Else
                    MsgBox "Error" & vbNewLine & "Ready state: " & .readyState & _
                    vbNewLine & "HTTP request status: " & .Status
                End If
            End With
            Dim Bilgiler As New Collection
            For Each TDelement In doc.getElementsByTagName("TD")
                Bilgiler.Add (TDelement.innerText)
                If TDelement.innerText = "Posta Kodu" Then
                    Ülke = Bilgiler(9)
                    iladı = Bilgiler(13)
                    Exit For
                End If
            Next
            Set Bilgiler = Nothing
 
Olumlu oy 0 Negatif oyla
Ali ÖZ' Alıntı:
Burayı;
MsgBox (myRegion)

Bu şekilde değiştirin.
range("b65536").end(3)(2,1) = myRegion
Genişletmek için tıkla...
hocam tekrar teşekkür ederim ancak bu şekilde düzelttiğimde hep A2 deki formül sonucunu veriyor. ben A2 nin sonucunu b2 ye A3'ün sonucunu B3'e verdirmek istiyorum. Ve tuşa bir kez tıkladığımda dolu olan son A'daki hücreye kadar B sütununda sonuç vermesini istiyorum.

Cevap verdiğiniz için tekrar teşekkürler.
 
Olumlu oy 0 Negatif oyla
Kod: 
Private Sub CommandButton1_Click()
    Dim strURL As String, XDoc As Object
    for i = 2 to range("a65536").end(3).row
    ipAddress = Range("A" & i).Value
    Set XDoc = CreateObject("MSXML2.DOMDocument")
    XDoc.async = False
    XDoc.validateOnParse = False

    strURL = "http://ip-api.com/xml/" & ipAddress
    XDoc.Load strURL

    myIP = XDoc.SelectSingleNode("query/query").Text
    myCountry = XDoc.SelectSingleNode("query/country").Text
    myRegion = XDoc.SelectSingleNode("query/regionName").Text
    myCity = XDoc.SelectSingleNode("query/city").Text

   range("b" & i).value = myRegion
   next

    Set XDoc = Nothing
End Sub
 
Olumlu oy 1 Negatif oyla
Çözüm
Durum
Konu Çözümlendiği İçin Kapatılmıştır.
Geri
Üst