web sayfasından veri almak.

musculus2

Altın Üye
Altın Üye
Katılım
23 Şubat 2007
Mesajlar
112
Excel Vers. ve Dili
2013 türkçe
http://www.ceddcozum.com/ çocuklarda boy kilo ve doğum tarihi girildiğinde erişkinlerden farklı bir şekilde bir hesaplama yapan halka açık bir site.

10000 den fazla verim var.
sayfada
doğum tarihi olarak 23.06.2012
cinsiyet Kadın(K)
ağırlık 15
boy 118
verilerini girince bana

ağırlık SDS Boy SDS VKİ SDS
-2.72 -0.29 -4.73
verilerini alıyorum.Ama bunu tek tek yapıyorum.
Excelde veriler girişmiş halde bu sayfadan doğum tarihi boy kilo cinziyet bilgilerini sayfaya girip oaradaki ağırlık SDS Boy SDS VKİ SDS verilerini, alma yöntemi varmı acaba ?
 

Ekli dosyalar

Katılım
24 Nisan 2005
Mesajlar
3,652
Excel Vers. ve Dili
Office 2016 EN 64 Bit
E ve K seçimi yaparak sorgulama yapar ve SDS bilgilerini kaydeder.
Tarih biçimi aa/gg/yyyy olmalıdır.

İnternet Explorer da bir defa TR seçilmiş olmalı.

Kod:
'Asri Akdeniz - www.asriakdeniz.com - asriakdeniz@gmail.com
Dim islem, URL, tarih, agirlik, boy, cinsiyet As String
Dim ie As Object
Dim objCollection As Object
Dim i As Long


Sub menu()
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    FindAndTerminate "IExplore.exe"
    For i = 2 To sonsatir
       URL = "http://www.ceddcozum.com"
       tarih = Replace(Cells(i, "B").Value, ".", "/")
       cinsiyet = Cells(i, "C").Value
       agirlik = Cells(i, "D").Value
       boy = Cells(i, "E").Value
    
       Call url_ac
       Call tikla
       ie.Quit
    Next i

    MsgBox ("Sorgulama işlemi tamamlandı.")
End Sub

Sub bekle()
    With ie
        Do Until .readyState = 4: DoEvents: Loop
        Do While .Busy: DoEvents: Loop
    End With
End Sub

Sub url_ac()

    Set ie = CreateObject("InternetExplorer.Application")
    With ie
      .Navigate URL
      .Visible = 1
    End With

basla:
   DoEvents
   Call bekle
   If InStr(ie.document.body.innerText, "Auxology") > 0 Or InStr(ie.document.body.innerText, "Oksoloji") > 0 Then
    
   Else
      GoTo basla
   End If

End Sub

Sub tikla()

    Set objCollection = ie.document.getElementsByTagName("input")
    j = 0
    Do While j < objCollection.Length
      If objCollection(j).Name = "DateOfBirth" Then
         objCollection(j).Value = tarih
      End If
      If objCollection(j).Name = "Gender" Then
         If cinsiyet = "E" And objCollection(j).Value = "True" Then objCollection(j).Checked = True
         If cinsiyet = "K" And objCollection(j).Value = "False" Then objCollection(j).Checked = True
      
      End If
      If objCollection(j).Name = "Weight" Then
         objCollection(j).Value = agirlik
      End If
      If objCollection(j).Name = "Height" Then
         objCollection(j).Value = boy
      End If
    
      j = j + 1
    Loop
  

  
        Set objCollection = ie.document.getElementsByTagName("Button")
    j = 0
    Do While j < objCollection.Length
      If objCollection(j).innerText = "Calculate" Or objCollection(j).innerText = "Hesapla" Then
         objCollection(j).Click
         Exit Do
      End If
      j = j + 1
    Loop
  
basla:
   DoEvents
   Call bekle
   If InStr(ie.document.body.innerText, "Ağırlık SDS :") > 0 Then
    
   Else
      GoTo basla
   End If

   veri = ie.document.body.innerHTML
   aranan = "Ağırlık SDS"
   asdsveri = Mid(veri, InStr(veri, aranan) + Len(aranan) + 1, Len(veri))
   asds = Replace(bilgial(asdsveri, ";", "<"), "&nbsp;", "")

   aranan = "Boy SDS"
   bsdsveri = Mid(veri, InStr(veri, aranan) + Len(aranan) + 1, Len(veri))
   bsds = Replace(bilgial(bsdsveri, ";", "<"), "&nbsp;", "")

   aranan = "VKİ SDS"
   vsdsveri = Mid(veri, InStr(veri, aranan) + Len(aranan) + 1, Len(veri))
   vsds = Replace(bilgial(vsdsveri, ";", "<"), "&nbsp;", "")
   Range("F" & i).Value = CDbl(asds)
   Range("G" & i).Value = CDbl(bsds)
   Range("H" & i).Value = CDbl(vsds)

End Sub

Function bilgial(veristr, arananstr, sonkarakterstr) As String
    basla = InStr(veristr, arananstr)
    If basla > 0 Then
       veristr = Mid(veristr, basla + Len(arananstr), Len(veristr))
       bilgial = Mid(veristr, 1, InStr(veristr, sonkarakterstr) - 1)
    End If
End Function

Sub FindAndTerminate(ByVal strProcName As String)
    Dim objWMIService, objProcess, colProcess
    Dim strComputer, strList
    strComputer = "."
    Set objWMIService = GetObject("winmgmts:" _
    & "{impersonationLevel=impersonate}!\\" _
    & strComputer & "\root\cimv2")
    Set colProcess = objWMIService.ExecQuery _
    ("Select * from Win32_Process Where Name = '" & strProcName & "'")
    If colProcess.Count > 0 Then
        For Each objProcess In colProcess
            objProcess.Terminate
        Next objProcess
    End If
End Sub
 

Ekli dosyalar

Son düzenleme:

musculus2

Altın Üye
Altın Üye
Katılım
23 Şubat 2007
Mesajlar
112
Excel Vers. ve Dili
2013 türkçe
ilginiz için teşekkür ederim.
Sorun galiba sayfanın ingilizce olmasından kaynaklı çünkü manuel olarak veri girdiğimde de aynı hatayı veriyor.
Sağ üstte EN/TR seçeneğini TR yapınca aynı hatayı vermiyor.
Fakat :basla döngüsünde takılı kalıyor.
 
Katılım
24 Nisan 2005
Mesajlar
3,652
Excel Vers. ve Dili
Office 2016 EN 64 Bit
ilginiz için teşekkür ederim.
Sorun galiba sayfanın ingilizce olmasından kaynaklı çünkü manuel olarak veri girdiğimde de aynı hatayı veriyor.
Sağ üstte EN/TR seçeneğini TR yapınca aynı hatayı vermiyor.
Fakat :basla döngüsünde takılı kalıyor.
Program sayfanın yüklendiğini döngüdeki "Auxology" metninden anlıyor. Döngüdeki "Auxology" metnini "Oksoloji" olarak değiştirin. Döngüden çıkacaktır.

Tabi bu durumda şöyle bir sorun var. IE de TR seçilmemiş olacağı için sorun olacak.
Programı uygun bir zamanda güncellerim.


İyi çalışmalar.
 

musculus2

Altın Üye
Altın Üye
Katılım
23 Şubat 2007
Mesajlar
112
Excel Vers. ve Dili
2013 türkçe
:)
Evet döngüden kurtuldu.
Fakat verileri web sayfasına giriş yapıulıyor.
Ama WEB sayfasındaki hesaplama yapılıp yapılan hesaplama sonucu excele gelmiyor. :(
Zor bir konu(benim için) yardımlarınız için teşekkür ederim.
 
Katılım
24 Nisan 2005
Mesajlar
3,652
Excel Vers. ve Dili
Office 2016 EN 64 Bit
:)
Evet döngüden kurtuldu.
Fakat verileri web sayfasına giriş yapıulıyor.
Ama WEB sayfasındaki hesaplama yapılıp yapılan hesaplama sonucu excele gelmiyor. :(
Zor bir konu(benim için) yardımlarınız için teşekkür ederim.
Dediğim gibi site sonucu göstermediği için bilgi alma bölümü eklenmedi.
Uygun bir zamanda eklerim. Sanırım hafta sonu olur.

İyi çalışmalar.
 

musculus2

Altın Üye
Altın Üye
Katılım
23 Şubat 2007
Mesajlar
112
Excel Vers. ve Dili
2013 türkçe
Harikasınız
Teşekkür ederim.
 
Katılım
24 Nisan 2005
Mesajlar
3,652
Excel Vers. ve Dili
Office 2016 EN 64 Bit
Dosya ve kod güncellendi.
Kontrol ediniz.
 

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,553
Excel Vers. ve Dili
Pro Plus 2021
Ekteki exe dosyası; excel dosyanız ile aynı yerde olmalı. Çok da stabil bir program olmadı ama kontrol edin.
 

Ekli dosyalar

musculus2

Altın Üye
Altın Üye
Katılım
23 Şubat 2007
Mesajlar
112
Excel Vers. ve Dili
2013 türkçe
Sayın Asri kodlar harika çalışıyor emekleriniz için teşekkür ederim.
 

musculus2

Altın Üye
Altın Üye
Katılım
23 Şubat 2007
Mesajlar
112
Excel Vers. ve Dili
2013 türkçe
Sayın Veyselemre emekleriniz için teşekkür ederim.
 

musculus2

Altın Üye
Altın Üye
Katılım
23 Şubat 2007
Mesajlar
112
Excel Vers. ve Dili
2013 türkçe
Sayın Asri kodlarınız şiir gibi hayran kaldım.
 
Üst