Bağkur No Sorgula ve P sütununa 4. satıdan itibaren yaz

[hsayar]

Not: Dosya sn Halukun dosyası olup üzerinde baya bir oynadım. Umarım kendisi beni mazur görür. Ekli dosya çalışmaktadır, veri aldığı satır boşsa ve değeri cDate ile listelerseniz isim soy isim tutan herkesi listeliyor, doğum yılını kontorl etmiyor bağkurun bugu


Mesleki hocam en altta cevap yazmış kendisine teşekkür ederim ben cevabı gördüğümde işi halletmiştim (Acemi Şansı ve firefox sağolsun bağkurun kaynak kodunu görünce işimi kolylaştırdı)

Yalnız iki Sorun var
1) Mevcut kodlara;
AynıTC numarasına iki tane bağkur numarası çıkması ender rastlanan bir durum olmak ile beraber çiftçi, esnaf bağkurluluğu gibi durumlarda mümkündür. Çoklu kayıtlarda o sütununda hangi satıra x konmuş ise o satırı aktarmasını istiyorum (veriler G5:N65536 şeklinde listeleniyor.
kontrolü.

2) For NExt döngüsü
For next döngüsü ile yazılması mümkünse hiçbir durumda hata vermeden
Hatayı u daki satır nosuna yazsın (MESALA SATIR NO 4 İÇİN)

Soyad hücresi boşsa U4 = "Soyad boş"
Ad hücresi boşsa U4 = "ad boş"
Doğum Tarihi boşsa U4 = "Tarih boş"
Sonuçlarda "Kayıt yok" çıkarsa U4 = "kAYIT yOK"
Sonuçlarda Çoğul Kayıt çıkarsa U4 = "Çoğul Kayıt" yazacak (örnek durumu inceleyiniz) ve Next for ile satır no 1 artarak 5 olacak
Bu sayfada 5. satıra da hatalı satır no yazılacak


+) '=============================================
Mümkünse birde comboboxtan verilerin aktarılacağı sayfa, sütun aralığı, ve başlangıç satır nosu girilisin
bu baya bir abartılı oldu galiba önce yukarıdakileri çözelim bu durum beyin jimnastiği isteyenlere

 

[hsayar]

http://www.excel.web.tr/showthread.php?t=17204
linki 1. mesada
bir örnek buldum o sadece verilen ad, soyad bilgilerine göre o isim, soyisim, ve doğum tarihine (tek satır) sahip bağkurluları listeliyor.

ama bende farklı olarak tc kimlik nosuda var ve veri sayısı çok fazla

 

[hsayar]

dolayısı ile Aynı Tc. kimlik nosuna sahip olan kişi olmadığı için birden fazla satır dönem olasılığıda yok.... (varmış çiftçi bağkur, esnaf bağkur noları farklıdır)

Eğer bu zaman kaybı veya tasarlanması uzun diyorsanız aklıma bir şey geldi ama ne kadar mümkün bilmiyorum;
benim sayfam ile oraDAKİ BAĞKUR3.XLS deki sayfa birleştirilse ve benim sütunlarımdak veriler sıra ile doldurulacak alanlara yazılsa eğer bir den fazla kişi bulundu ise bağkur no alanına (P sütunu, verinin alındığı satır) çoğul, eğer kişi yoksa "KAYIT YOK" yazsın....
ben artık onları bir zahmet elle yaparım...
kusura bakmayın mantık var faailiyet yok

 

[Mahmut Kök]

Sayfada sorgulayacağınız satırı seçip kodu çalıştırın. Geçerli bir veri bilmediğim için olumlu dönen sorgulamaların sonucunu sayfaya yazdıramadım. Kaydı olan gerçek bir isim bilgisini özel ileti olarak bildirebilirseniz, yardımcı olmaya çalışırım.

SAT = ActiveCell.Row
Set ie = CreateObject("internetexplorer.Application")
ie.Visible = True
ie.navigate "[URL]http://www.bagkur.gov.tr/sigortali/adSoyArama.shtml[/URL]"
Application.Wait (Now + TimeValue("00:00:3"))
 
ie.document.all.kimlik.Value = Cells(SAT, 1)
ie.document.all.ad.Value = Cells(SAT, 2)
ie.document.all.soyad.Value = Cells(SAT, 3)
ie.document.all.yil.Value = Right(Cells(SAT, 7), 4)

 

[hsayar]

1. mesaj
1. aşamanın çözülmesi ve çözümünde eklenmesi nedenile değiştirlmiştir.
2. aşama için yardımlarınızı bekliyorum.
Saygılarımla

 

[hsayar]

    Const URL As String = "http://www.bagkur.gov.tr/sigortali/adSoyArama.shtml"

Sub BagKurSicNoSorg()



    'BagKur' dan sorgulama ....
    '28/06/2006 - Raider ®
    '
    'Dim Data(1 To 3) As String  ' Raider ® Satırı
    Dim Data(1 To 4) As String   'Edt_Hsyar
    Dim IE As Object
    Dim Temp As Variant
    Dim i As Integer, j As Integer
    Dim HTML_Body As Object, HTML_Tables As Object, MyTable As Object
    Dim HTML_TableRows As Object, HTML_TableDivisions As Object
    Dim RetVal As Variant
    Set s1 = Sheets("Sheet1")
    
    If s1.Range("d5").Value = "" Then
    MsgBox "Soyadınızı Giriniz"
    s1.Range("d5").Select
    Exit Sub
    End If
    
    If s1.Range("e5").Value = "" Then
    MsgBox "Adınızı Giriniz"
    s1.Range("e5").Select
    
    Exit Sub
    End If
    
    If s1.Range("f5").Value = "" Then
    MsgBox "Doğum Yılınızı Giriniz"
    s1.Range("f5").Select
    Exit Sub
    End If
    
    s1.Range("a1").Value = " V E R İ  S O R G U L A N I Y OR"
      
   ' Range("D4:L5").Clear
    Range("g4:o10").Select
    Selection.ClearContents

    Range("g4:o10").NumberFormat = "@"

    Data(1) = Range("d5")  'soyad
    Data(2) = Range("e5")  'ad
    Data(3) = Range("f5")  'doğum yılı
    Data(4) = Range("c5")  'tc__ek_hsayar
 [color="red"]   Set IE = CreateObject("InternetExplorer.Application") [/color]
    With IE
        .Navigate URL
        Application.Wait (Now + TimeValue("00:00:3"))
        Do Until IE.ReadyState = 4: DoEvents: Loop
        With .document.all
            .soyad.Value = Data(1)
            .ad.Value = Data(2)
            .yil.Value = Data(3)
            .kimlik.Value = Data(4) 'ek hsayar
        End With
        IE.document.forms("AdSoyForm").Elements("submitbtn").Click
        Do Until IE.ReadyState = 4: DoEvents: Loop
        Do While IE.Busy: DoEvents: Loop
        
        Set HTML_Body = IE.document.GetElementsByTagName("Body").Item(0)
        Set HTML_Tables = HTML_Body.GetElementsByTagName("Table")
        Set MyTable = HTML_Tables(6) '(6)
        i = 3 'verilerin yapıştırılmaya başladaığı satır
        
'       ***************************************************************************************
'       Eger isteseydik, butun tablolari ve icindeki hucrelerin icerigini asagidaki
'       For-Next dongusunu de koda dahil ederek elde edebilirdik
'       Ama biz kisa yoldan, bizimle ilgili olan 6nci tabloya yukarida SET atamasi yaptik
'       ***************************************************************************************
'    For Each Table In HTML_Tables
        On Error GoTo ErrHandler:
        Set HTML_TableRows = MyTable.GetElementsByTagName("Tr")
        For Each MyRow In HTML_TableRows
            j = 6 'verilerin yapıştırılmaya başladaığı Sütun
            i = i + 1
            Set HTML_TableDivisions = MyRow.GetElementsByTagName("Td")
            For Each Td In HTML_TableDivisions
                j = j + 1
                RetVal = Td.InnerText
                Cells(i, j) = RetVal
            Next
        Next
'    Next
    End With
    
    'Range("A4:A5").Copy
    'Range("D4:K5").PasteSpecial Paste:=xlFormats
    Range("g4:o10").ColumnWidth = 11
    Application.CutCopyMode = False
    s1.Range("a1").Value = " V E R İ  S O R G U L A  M A S I  B İ T T İ."

    Range("A7").Select
    GoTo SafeExit:
ErrHandler:
    Set MyTable = HTML_Tables(3)
    'MsgBox MyTable.Rows(1).Cells(0).InnerText, vbCritical, "Kullanicinin dikkatine !"
    's1.Range("d10") = MyTable.Rows(1).Cells(0).InnerText
    s1.Range("g5").Value = "kayıt bulunamadı"
    s1.Range("a1").Value = "  K İ Ş İ     Y O K ."

SafeExit:
    Set HTML_Body = Nothing
    Set HTML_Tables = Nothing
    Set MyTable = Nothing
    Set HTML_TableRows = Nothing
    Set HTML_TableDivisions = Nothing
    Set IE = Nothing
End Sub

10-15 sorgulama yaptıktan sonra kırmızı satıra gelince
Run time error -2147467259 (80004005) Automaotion error belirtilmemiş hata mesajı veriyor. bazende vba ekranında orayı sarı ile işaretleyip duruyor.

bu mesajın sebebi nedir?
Bunu ekrana vermek yerine a1 hücresine belirtilmemiş hata yazsa ve exit sub ile işlem sonlansa mümkünmü

 

[BDemirsoy]

selamlar arkadaşlar. Örneklere göz atamıyorum. Yardım ederseniz sevinirim.