Toplu Sorgu

Kusta · Bugün 10:06

Herkese Merhaba,
Aşağıdaki kod ile A sütununa yazdığım TC lerin adresleri çekebilmekteyim.
İşlemi tek tek yapmaktadır.
Yapmak istediğim, örneğin A sütununa 50 tane TC yazdığımda bunları tek tek değil de 50 sekme açarak aynı anda hepsinin sorgusunu yapması ve karşısına adreslerini yazması.
Bunu nasıl yapabilirim.

Sub _Arama()
Dim IE As Object
Set IE = CreateObject("InternetExplorer.Application")
Application.Wait Now + TimeValue("00:00:02")
IE.Navigate "https:/.........../Ortak/KpsAdresBilgisi.aspx"
Application.Wait Now + TimeValue("00:00:02")
IE.Width = 1500
IE.Height = 1000
IE.Visible = False
While IE.Busy
DoEvents
Wend
son = Cells(Rows.Count, "A").End(3).Row
For i = 2 To son
If Cells(i, "E") = "İŞLEM TAMAM" Then
GoTo 0

Else

IE.Document.getElementById("ctl04_ctlTCKimlikNo").Value = Cells(i, "A")
IE.Visible = False
While IE.Busy
DoEvents
Wend
Set TrackID = IE.Document.getElementById("ctl04_ctlDogumTarihi_textBox")
IE.Document.getElementById("ctl04_ctlDogumTarihi_textBox").Value = ""
IE.Visible = False
While IE.Busy
DoEvents
Wend

Set TrackID = IE.Document.getElementById("ctl04_ctlKpsAdresPageCommand_CommandItem_Search")
IE.Document.getElementById("ctl04_ctlKpsAdresPageCommand_CommandItem_Search").Click
IE.Visible = False
While IE.Busy
DoEvents
Wend
Application.Wait Now + TimeValue("00:00:02")
On Error Resume Next
Cells(i, 6) = IE.Document.getElementById("ctl04_ctlMessageBox_lblMessage").innerText

On Error Resume Next
IE.Document.getElementById("ctl04_ctlMessageBox_btnClose").Click
On Error GoTo 0

On Error Resume Next
Cells(i, "C") = IE.Document.getElementById("ctl04_ctlAdresBilgi").Value
Cells(i, "D") = IE.Document.getElementById("ctl04_ctlIlIlce").Value
Cells(i, "B") = IE.Document.getElementById("ctl04_ctlDogumTarihi_textBox").Value
On Error GoTo 0
IE.Visible = False
While IE.Busy
DoEvents
Wend

Cells(i, "E") = "İŞLEM TAMAM"
IE.Visible = False
While IE.Busy
DoEvents
Wend
0:

End If
Next
IE.Quit
MsgBox "İŞLEM TAMAMLANDI. İYİ ÇALIŞMALAR."

End Sub

halit3 · Bugün 10:39

Eğer kodlarınız doğru çalışıyorsa döngüyü internet adresinden önce yapmalısınız.

Kod:

Sub Arama()
Dim IE As Object

son = Cells(Rows.Count, "A").End(3).Row
For i = 2 To son
If Cells(i, "E") = "İŞLEM TAMAM" Then
GoTo 0

Else

Set IE = CreateObject("InternetExplorer.Application")
Application.Wait Now + TimeValue("00:00:02")
IE.Navigate "https:/.........../Ortak/KpsAdresBilgisi.aspx"
Application.Wait Now + TimeValue("00:00:02")
IE.Width = 1500
IE.Height = 1000
IE.Visible = False
While IE.Busy
DoEvents
Wend


IE.Document.getElementById("ctl04_ctlTCKimlikNo").Value = Cells(i, "A")
IE.Visible = False
While IE.Busy
DoEvents
Wend
Set TrackID = IE.Document.getElementById("ctl04_ctlDogumTarihi_textBox")
IE.Document.getElementById("ctl04_ctlDogumTarihi_textBox").Value = ""
IE.Visible = False
While IE.Busy
DoEvents
Wend



Set TrackID = IE.Document.getElementById("ctl04_ctlKpsAdresPageCommand_CommandItem_Search")
IE.Document.getElementById("ctl04_ctlKpsAdresPageCommand_CommandItem_Search").Click
IE.Visible = False
While IE.Busy
DoEvents
Wend
Application.Wait Now + TimeValue("00:00:02")
On Error Resume Next
Cells(i, 6) = IE.Document.getElementById("ctl04_ctlMessageBox_lblMessage").innerText

On Error Resume Next
IE.Document.getElementById("ctl04_ctlMessageBox_btnClose").Click
On Error GoTo 0


On Error Resume Next
Cells(i, "C") = IE.Document.getElementById("ctl04_ctlAdresBilgi").Value
Cells(i, "D") = IE.Document.getElementById("ctl04_ctlIlIlce").Value
Cells(i, "B") = IE.Document.getElementById("ctl04_ctlDogumTarihi_textBox").Value
On Error GoTo 0
IE.Visible = False
While IE.Busy
DoEvents
Wend



Cells(i, "E") = "İŞLEM TAMAM"
IE.Visible = False
While IE.Busy
DoEvents
Wend
0:
IE.Quit
End If
Next

MsgBox "İŞLEM TAMAMLANDI. İYİ ÇALIŞMALAR."

End Sub

Kusta · Bugün 10:56

halit3' Alıntı:

Eğer kodlarınız doğru çalışıyorsa döngüyü internet adresinden önce yapmalısınız.

Kod:

Sub Arama()
Dim IE As Object

son = Cells(Rows.Count, "A").End(3).Row
For i = 2 To son
If Cells(i, "E") = "İŞLEM TAMAM" Then
GoTo 0

Else

Set IE = CreateObject("InternetExplorer.Application")
Application.Wait Now + TimeValue("00:00:02")
IE.Navigate "https:/.........../Ortak/KpsAdresBilgisi.aspx"
Application.Wait Now + TimeValue("00:00:02")
IE.Width = 1500
IE.Height = 1000
IE.Visible = False
While IE.Busy
DoEvents
Wend


IE.Document.getElementById("ctl04_ctlTCKimlikNo").Value = Cells(i, "A")
IE.Visible = False
While IE.Busy
DoEvents
Wend
Set TrackID = IE.Document.getElementById("ctl04_ctlDogumTarihi_textBox")
IE.Document.getElementById("ctl04_ctlDogumTarihi_textBox").Value = ""
IE.Visible = False
While IE.Busy
DoEvents
Wend



Set TrackID = IE.Document.getElementById("ctl04_ctlKpsAdresPageCommand_CommandItem_Search")
IE.Document.getElementById("ctl04_ctlKpsAdresPageCommand_CommandItem_Search").Click
IE.Visible = False
While IE.Busy
DoEvents
Wend
Application.Wait Now + TimeValue("00:00:02")
On Error Resume Next
Cells(i, 6) = IE.Document.getElementById("ctl04_ctlMessageBox_lblMessage").innerText

On Error Resume Next
IE.Document.getElementById("ctl04_ctlMessageBox_btnClose").Click
On Error GoTo 0


On Error Resume Next
Cells(i, "C") = IE.Document.getElementById("ctl04_ctlAdresBilgi").Value
Cells(i, "D") = IE.Document.getElementById("ctl04_ctlIlIlce").Value
Cells(i, "B") = IE.Document.getElementById("ctl04_ctlDogumTarihi_textBox").Value
On Error GoTo 0
IE.Visible = False
While IE.Busy
DoEvents
Wend



Cells(i, "E") = "İŞLEM TAMAM"
IE.Visible = False
While IE.Busy
DoEvents
Wend
0:
IE.Quit
End If
Next

MsgBox "İŞLEM TAMAMLANDI. İYİ ÇALIŞMALAR."

End Sub

Halit bey merhaba, Öncelikle her zamanki gibi ilginiz için teşekkür ederim.
Kod çalışıyor, sizin düzeltmenize göre tekrar denedim ama yine tek tek yapıyor. A2 hücresindeki tc nin sorgusu bitince diğerine geçiyor sonra diğerine.... diye gidiyor.
Yanlış ifade etmiş olabilirim, Ben A sütununa kaç tane TC girdiysem o kadar sekmeyi aynı anda açıp, açılan sekmelerde A sütunundaki tc leri aynı anda sorgulamasını istiyorum. Amacım zamandan tasarruf 100 tc yi 20 dk da bitiriyorsa, hepsini aynı anda yaparsa 3 dk da bitirmesi.
Ben işin içinden çıkamadım sizin gibi üstadlar iyi ki varlar,

Korhan Ayhan · Bugün 12:10

Merhaba,

Deneme şansım yok ama aşağıdaki yapıyı bir deneyiniz.

C++:

Sub Fast_Find()
    Dim IE As Object
    Dim Doc As Object
    Dim i As Long, son As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Set IE = CreateObject("InternetExplorer.Application")
    IE.Visible = False
    IE.Navigate "https://....../Ortak/KpsAdresBilgisi.aspx"
    
    WaitReady IE
    
    Set Doc = IE.Document
    son = Cells(Rows.Count, "A").End(xlUp).Row
    
    For i = 2 To son
        If Cells(i, "E").Value <> "İŞLEM TAMAM" Then
            
            ' TCKN
            With Doc
                .getElementById("ctl04_ctlTCKimlikNo").Value = Cells(i, "A").Value
                .getElementById("ctl04_ctlDogumTarihi_textBox").Value = ""
                .getElementById("ctl04_ctlKpsAdresPageCommand_CommandItem_Search").Click
            End With
            
            WaitReady IE, 3
            
            On Error Resume Next
            Cells(i, "F").Value = Doc.getElementById("ctl04_ctlMessageBox_lblMessage").innerText
            Doc.getElementById("ctl04_ctlMessageBox_btnClose").Click
            Cells(i, "C").Value = Doc.getElementById("ctl04_ctlAdresBilgi").Value
            Cells(i, "D").Value = Doc.getElementById("ctl04_ctlIlIlce").Value
            Cells(i, "B").Value = Doc.getElementById("ctl04_ctlDogumTarihi_textBox").Value
            On Error GoTo 0
            
            Cells(i, "E").Value = "İŞLEM TAMAM"
        End If
    Next i
    
    IE.Quit
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    MsgBox "İŞLEM TAMAMLANDI.", vbInformation
End Sub

Private Sub WaitReady(IE As Object, Optional seconds As Double = 1)
    Dim t As Double
    t = Timer
    Do
        DoEvents
        If Not IE.Busy Then
            If IE.readyState = 4 Then Exit Do
        End If
        If Timer - t > seconds Then Exit Do
    Loop
End Sub

Kusta · Bugün 13:23

Korhan Ayhan' Alıntı:

Merhaba,

Deneme şansım yok ama aşağıdaki yapıyı bir deneyiniz.

C++:

Sub Fast_Find()
    Dim IE As Object
    Dim Doc As Object
    Dim i As Long, son As Long
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
   
    Set IE = CreateObject("InternetExplorer.Application")
    IE.Visible = False
    IE.Navigate "https://....../Ortak/KpsAdresBilgisi.aspx"
   
    WaitReady IE
   
    Set Doc = IE.Document
    son = Cells(Rows.Count, "A").End(xlUp).Row
   
    For i = 2 To son
        If Cells(i, "E").Value <> "İŞLEM TAMAM" Then
           
            ' TCKN
            With Doc
                .getElementById("ctl04_ctlTCKimlikNo").Value = Cells(i, "A").Value
                .getElementById("ctl04_ctlDogumTarihi_textBox").Value = ""
                .getElementById("ctl04_ctlKpsAdresPageCommand_CommandItem_Search").Click
            End With
           
            WaitReady IE, 3
           
            On Error Resume Next
            Cells(i, "F").Value = Doc.getElementById("ctl04_ctlMessageBox_lblMessage").innerText
            Doc.getElementById("ctl04_ctlMessageBox_btnClose").Click
            Cells(i, "C").Value = Doc.getElementById("ctl04_ctlAdresBilgi").Value
            Cells(i, "D").Value = Doc.getElementById("ctl04_ctlIlIlce").Value
            Cells(i, "B").Value = Doc.getElementById("ctl04_ctlDogumTarihi_textBox").Value
            On Error GoTo 0
           
            Cells(i, "E").Value = "İŞLEM TAMAM"
        End If
    Next i
   
    IE.Quit
   
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    MsgBox "İŞLEM TAMAMLANDI.", vbInformation
End Sub

Private Sub WaitReady(IE As Object, Optional seconds As Double = 1)
    Dim t As Double
    t = Timer
    Do
        DoEvents
        If Not IE.Busy Then
            If IE.readyState = 4 Then Exit Do
        End If
        If Timer - t > seconds Then Exit Do
    Loop
End Sub

Merhaba Korhan bey, eliniz kolunuz ağrımasın bu yapıda güzel çalışıyor fakat adım adım gittiğimde de gördüğüm bir sorgu bitince diğerine geçiyor. Hal böyle olunca süreç aynı işliyor.
Normalde 1 kişiyi 2 sn de sorgulayıp veriyi alıyor 76 kişi denedim 113 sn de hepsini getirdi. (Benim kodda da süre aynı)
76 kişi için explorer da aynı anda 76 sekme açıp hepsini aynı anda sorgulayıp yazmasını istiyorum. Yani 1 kişi 2 sn sürüyosa 76 kişiyi de aynı anda sekme açıp sorguladığı için 2 sn de bitirmesi gibi düşünebiliriz. Tabi çok sekme olunca belki biraz yavaş yapar ama hadi 10 sn de yapsın.
Hakkınızı helal edin yoruyorum sizi ama sizlerden başkası da çözemez bu olayı.

Korhan Ayhan · Bugün 13:48

Merhaba,

IE için aynı anda çoklu pencere açıp senkron olarak sorgulama yapmak söylerken hızlı çalışacakmış gibi görünebilir. Emin değilim ama aynı anda bu kadar çok pencere CPU'yu zorlayacaktır. Bu da sonuçların daha yavaş gelmesine neden olacaktır.

Hız istiyorsanız kodlama tekniğini değiştirmenizde fayda var.

Mesela web sorguları için sayfa yapısıda uygunsa CreateObject("MSXML2.XMLHTTP") nesnesi daha iyi performans verecektir.

Forumda bununla ilgili örnekler var. İncelerseniz yol alabilirsiniz.

Muzaffer Ali · Bugün 14:20

Sayın Korhan Ayhan'ın paylaştığı kodlarda revize yaptım.
Deneme şansım olmadığı için deneyemedim.
Hız konusunda ne kadar etkili olur bilemem, deneyiniz.

Kod:

Sub Fast_Find()
    Dim IE() As Object
    Dim Doc As Object
    Dim i As Long, son As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    son = Cells(Rows.Count, "A").End(xlUp).Row
    ReDim IE(son - 2)
    
    For i = 2 To son
        Set IE(i - 2) = CreateObject("InternetExplorer.Application")
        IE(i - 2).Visible = False
        IE(i - 2).Navigate "https://....../Ortak/KpsAdresBilgisi.aspx"
        
        WaitReady IE(i - 2)
        
    Next
    For i = 2 To son
        Set Doc = IE(i - 2).Document
        If Cells(i, "E").Value <> "İŞLEM TAMAM" Then
            
            ' TCKN
            With Doc
                .getElementById("ctl04_ctlTCKimlikNo").Value = Cells(i, "A").Value
                .getElementById("ctl04_ctlDogumTarihi_textBox").Value = ""
                .getElementById("ctl04_ctlKpsAdresPageCommand_CommandItem_Search").Click
            End With
            
            WaitReady IE(i - 2), 3
            
            On Error Resume Next
            Cells(i, "F").Value = Doc.getElementById("ctl04_ctlMessageBox_lblMessage").innerText
            Doc.getElementById("ctl04_ctlMessageBox_btnClose").Click
            Cells(i, "C").Value = Doc.getElementById("ctl04_ctlAdresBilgi").Value
            Cells(i, "D").Value = Doc.getElementById("ctl04_ctlIlIlce").Value
            Cells(i, "B").Value = Doc.getElementById("ctl04_ctlDogumTarihi_textBox").Value
            On Error GoTo 0
            
            Cells(i, "E").Value = "İŞLEM TAMAM"
        End If
        IE(i - 2).Quit
    Next i
    
   
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    MsgBox "İŞLEM TAMAMLANDI.", vbInformation
End Sub

Private Sub WaitReady(IE As Object, Optional seconds As Double = 1)
    Dim t As Double
    t = Timer
    Do
        DoEvents
        If Not IE.Busy Then
            If IE.ReadyState = 4 Then Exit Do
        End If
        If Timer - t > seconds Then Exit Do
    Loop
End Sub

hasankardas · Bugün 16:13

Kusta' Alıntı:
Merhaba Korhan bey, eliniz kolunuz ağrımasın bu yapıda güzel çalışıyor fakat adım adım gittiğimde de gördüğüm bir sorgu bitince diğerine geçiyor. Hal böyle olunca süreç aynı işliyor.
Normalde 1 kişiyi 2 sn de sorgulayıp veriyi alıyor 76 kişi denedim 113 sn de hepsini getirdi. (Benim kodda da süre aynı)
76 kişi için explorer da aynı anda 76 sekme açıp hepsini aynı anda sorgulayıp yazmasını istiyorum. Yani 1 kişi 2 sn sürüyosa 76 kişiyi de aynı anda sekme açıp sorguladığı için 2 sn de bitirmesi gibi düşünebiliriz. Tabi çok sekme olunca belki biraz yavaş yapar ama hadi 10 sn de yapsın.
Hakkınızı helal edin yoruyorum sizi ama sizlerden başkası da çözemez bu olayı.

Sistem buna izin vermiyordur. siz istediğiniz kadar sekme açın bir sorgu bitmeden diğerinin işlemini yaptırmıyordur.

Toplu Sorgu

Kusta

halit3

Uzman

Kusta

Korhan Ayhan

Administrator

Kusta

Korhan Ayhan

Administrator

Muzaffer Ali

Destek Ekibi

hasankardas