Excel Forum
ALTIN ÜYELİK Hakkında Bilgi


Geri Git   Excel Forum > EXCEL-Soruları > Makro-VBA
Atatürk
Şifremi Unuttum

DUYURU SİSTEMİ / REKLAM PANOSU

Makro-VBA Makro veya VBA ile ilgili sorularınızı buraya gönderebilirsiniz.
Dosya ekleyebilirsiniz

Özel Arama


Yanıtla
 
Paylaş Konu Araçları Görünüm Modları
Eski 04-09-2015, 18:18   #1
SAGULNET
 
Giriş: 27/02/2012
Şehir: dfdfg
Mesaj: 27
Excel Vers. ve Dili:
2010
Exclamation Parsel Sorgusu için önemli bir konu

Sayın Excel.web.tr dostları size önemli bir soru sormak istiyorum.
İşlerimizde kullanacağım basit bir şey yapmak istiyorum, vatan - millet meselesi :-)
Siz değerli dostlarım yardımcı olursa Allah bin kere razı olsun.

bir kod yardımı ile
https://parselsorgu.tkgm.gov.tr/ sitesine gireceğim ve

İdari Sorgu Coğrafi Sorgu dan coğrafi sorguyu seçecek, buradaki enleme ve boylama A1 VE A2 hücresindeki değerleri yazacak.


Yardım eden arkadaşlara çok teşekkürler.
SAGULNET Çevrimdışı   Alıntı Yaparak Cevapla
Eski 04-09-2015, 23:13   #2
halit3
Uzman
 
halit3 kullanıcısının avatarı
 
Giriş: 18/01/2008
Mesaj: 10,476
Excel Vers. ve Dili:
2003 excel türkçe
Varsayılan

İlgili web sitesindeki text nesnelerin her seferinde adı değişiyor baya uğraştırdı.
Aşağıdaki kodu bir dene bazen boş gelirse yeniden deneyiniz.

kod:

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Sub verial()
Dim URL As String
Dim ie As Object

URL = "https://parselsorgu.tkgm.gov.tr/"
Set ie = CreateObject("InternetExplorer.Application")

With ie
.Navigate URL
.Visible = 1
ShowWindow ie.hwnd, 3

Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop
ie.document.all("cphMaster_rblSorguTip_1").Checked = True
ie.document.all("cphMaster_rblSorguTip_1").Click
Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop

Application.Wait (Now + TimeValue("00:00:01"))

On Error Resume Next

sat = 1

Set objInputs = ie.document.getElementsByTagName("input")
For Each nesne In objInputs

If nesne.ID Like "*" & "cphMaster" & "*" = True Then
If sat = 3 Then
ie.document.all(nesne.ID).Value = Replace(Cells(1, "A").Value, ".", ",")

End If

If sat = 4 Then
ie.document.all(nesne.ID).Value = Replace(Cells(2, "A").Value, ".", ",")

End If
sat = sat + 1
'nesne.Click
End If
Next

Application.Wait (Now + TimeValue("00:00:01"))
ie.document.all("ctl00$cphMaster$btnSorgu").Click

'ie.Quit: Set ie = Nothing
End With

End Sub
__________________





Forum Kuralları
halit3 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 05-09-2015, 02:12   #3
systran
Destek Ekibi
 
Giriş: 15/12/2007
Mesaj: 1,347
Excel Vers. ve Dili:
2007 [TR]
Varsayılan

Halit3 ün yazdığı kodlara ilave olarak eğer Sorgulama sonuçlarını da excele almak istersen şu örneği incele.
Sayfa1 deki A sütunu Enlem, B sütunu boylam bilgisini içerecek şekilde listelenen koordinatların bilgilerini (il, ilçe, ada parsel ...) sırayla sorgular ve yanlarına yazar.
https://drive.google.com/folderview?...Dg&usp=sharing
systran Çevrimdışı   Alıntı Yaparak Cevapla
Eski 05-09-2015, 03:51   #4
Ömer BARAN
Uzman
 
Giriş: 08/03/2011
Şehir: ANKARA / İSTANBUL
Mesaj: 9,226
Excel Vers. ve Dili:
Office 2013 TÜRKÇE
Varsayılan

Merhabalar, Sayın ÖZDEMİR ve Sayın systran.

Benim varsayılan internet tarayıcım Chrome.
Kodlar Internet Explorer'ı açtı, bilgiyi aldı ancak işlem bittikten sonra kapanmadı.
__________________
.
☾✭ İnadına TÜRKÇE ✭☽

-- Sorunuzu, gerçek belgenizle aynı yapıda ve olması gereken sonuçların elle yazıldığı örnek belge ile destekleyiniz.
-- ALTIN ÜYELİK öneriyorum. / FORUM KURALLARInı mutlaka okuyunuz.
-- ALTIN ÜYE olmayanlar, örnek belgeyi dosya.tc, dosya.co gibi bir siteye yükleyip, belgeye erişim adresini verebilir.
-- Özel mesaj ile soru sormayınız. / Geri bildirimde bulunulmayan cevaplarımı siliyorum.
Ömer BARAN Çevrimdışı   Alıntı Yaparak Cevapla
Eski 05-09-2015, 12:12   #5
systran
Destek Ekibi
 
Giriş: 15/12/2007
Mesaj: 1,347
Excel Vers. ve Dili:
2007 [TR]
Varsayılan

vba Chrome ile bu kadar ayrıntılı kullanılamıyor maalesef
Halit3 ün yazdığı kodların en sonunda ie.Quit satırı var, yorum satırı onu düzeltip deneyiniz.
systran Çevrimdışı   Alıntı Yaparak Cevapla
Eski 07-09-2015, 10:15   #6
SAGULNET
 
Giriş: 27/02/2012
Şehir: dfdfg
Mesaj: 27
Excel Vers. ve Dili:
2010
Varsayılan Merhaba

Çok teşekkür ederim yardımlarınız için. Allah razı olsun hepinizden. halit3 ve systran ayrıca ellerinize sağlık.
SAGULNET Çevrimdışı   Alıntı Yaparak Cevapla
Eski 07-09-2015, 10:33   #7
halit3
Uzman
 
halit3 kullanıcısının avatarı
 
Giriş: 18/01/2008
Mesaj: 10,476
Excel Vers. ve Dili:
2003 excel türkçe
Varsayılan

Alıntı:
SAGULNET tarafından gönderildi Mesajı Görüntüle
Çok teşekkür ederim yardımlarınız için. Allah razı olsun hepinizden. halit3 ve systran ayrıca ellerinize sağlık.
Teşekkürler iyi çalışmalar
__________________





Forum Kuralları
halit3 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 07-09-2015, 10:46   #8
tamer42
Destek Ekibi
 
tamer42 kullanıcısının avatarı
 
Giriş: 11/03/2005
Şehir: Ankara
Mesaj: 1,182
Excel Vers. ve Dili:
Office 2013 İngilizce
Varsayılan

Merhaba,

https://parselsorgu.tkgm.gov.tr
sitede ilgili bilgileri girerek; ekli görüntülerde olduğu gibi sorgulama yapabiliyoruz.

Sorgulama sonrasında “Koordinat İndir” butonuna basarak bir *.txt dosyası bilgisayarımıza kaydedilebilmektedir.

*.txt dosyasının kaydedilme işleminin Excel ortamında bir kod oluşturarak yapılması mümkün olabilir mi?


Teşekkürler, İyi Çalışmalar.
Eklenmiş Resimler
Dosya Türü: jpg parsel-sorgu.jpg (153.3 KB, 26 Görüntülenme)
tamer42 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 07-09-2015, 10:48   #9
SAGULNET
 
Giriş: 27/02/2012
Şehir: dfdfg
Mesaj: 27
Excel Vers. ve Dili:
2010
Varsayılan

kodun sonunda trs ve tds hata verdi. Acaba bunu nasıl düzeltiriz ?

dim trs,tds as ... gibi birşey tanımlamam lazım sanırım

Dim tbl As Object
Application.Wait (Now + TimeValue("00:00:01"))
Set tbl = ie.Document.getElementsByTagName("table")(5) '5. tablo arama sonuçlarının olduğu tablo


Dim trs As Tag
Set trs = tbl.getElementsByTagName("tr")(1)
Set tds = trs.getElementsByTagName("td")

Dim c As Integer
For c = 0 To tds.Length - 1
Sayfa1.Range("L" & iii).Offset(0, c).Value = tds(c).innerText
Next c
SAGULNET Çevrimdışı   Alıntı Yaparak Cevapla
Eski 07-09-2015, 11:31   #10
halit3
Uzman
 
halit3 kullanıcısının avatarı
 
Giriş: 18/01/2008
Mesaj: 10,476
Excel Vers. ve Dili:
2003 excel türkçe
Varsayılan

Bu kod ilgili sayfada A2 hücresinden aşağıya kadar Enlem, B2 hücresinden aşağıya kadar boylam kordinatlarını kod yatay olarak ilgili hücrelere getirmektedir.

kod:

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Sub verial10()
Dim URL As String
Dim ie As Object

yeni_dosya_adı = ActiveWorkbook.Name

Columns("C:K").ClearContents
son = Cells(Rows.Count, "a").End(3).Row

sat1 = 6

URL = "https://parselsorgu.tkgm.gov.tr/"
Set ie = CreateObject("InternetExplorer.Application")

With ie
.Navigate URL
.Visible = 1
ShowWindow ie.hwnd, 6


Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop

For k = 1 To 3
For i = 2 To son

If Cells(i, "c").Value <> "" Then
GoTo atla1
End If

ie.document.all("cphMaster_rblSorguTip_1").Checked = True
ie.document.all("cphMaster_rblSorguTip_1").Click
Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop


On Error Resume Next
sat = 1
Set objInputs = ie.document.getElementsByTagName("input")

For Each nesne In objInputs

deg1 = Split(nesne.ID, "rblSorguTip")
If UBound(deg1) > 0 Then
GoTo atla2
End If
deg2 = Split(nesne.ID, "btnSorgu")
If UBound(deg2) > 0 Then
GoTo atla2
End If
If nesne.ID Like "*" & "cphMaster" & "*" = True Then
ie.document.all(nesne.ID).Value = Replace(Cells(i, sat).Value, ".", ",")

sat = sat + 1
End If
atla2:
Next

Application.Wait (Now + TimeValue("00:00:01"))
ie.document.all("ctl00$cphMaster$btnSorgu").Click

Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop

Application.Wait (Now + TimeValue("00:00:01"))

Set t = ie.document.getElementsByTagName("table").Item(5)

If Cells(1, "c") = "" Then
For j = 0 To t.Cells.Length - 1
Cells(1, j + 3) = t.Rows(0).Cells(j).innerText
Next
End If

For j = 0 To t.Cells.Length - 1
Cells(i, j + 3) = t.Rows(1).Cells(j).innerText
Next

atla1:
Next i


Next k

'ie.Quit: Set ie = Nothing
End With

Windows(yeni_dosya_adı).Activate

MsgBox "işlem tamam"
End Sub
__________________





Forum Kuralları
halit3 Çevrimdışı   Alıntı Yaparak Cevapla
Yanıtla


Konu Araçları
Görünüm Modları

Gönderme Kuralları
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is Açık
SimgelerAçık
[IMG] kodu Açık
HTML kodu Kapalı


Saat 01:20


Bu forum Elit NET - www.elitnet.com.tr tarafından sunulmaktadır.

Excel Eğitimi - Mobil Uygulama - Çorlu - Çorlu Web Tasarım - Tarot Falı - invest in turkey - Lingerie - Dyeing Machine - Karton Bardak- Çorlu Özel Eğitim- Site Yönetimi- Led Aydınlatma- Pronet Tekirdağ- Çorlu Kamera- Pronet Edirne- Pronet Kırklareli- Pronet Çerkezköy- Pronet Çorlu- Pronet Lüleburgaz- Pronet Keşan- Çorlu Araç Takip- Çorlu Su Arıtma- Boru Profil- Gebze Emlak- Beylikdüzü Temizlik- İstanbul Burun Estetiği- Bakır Sülfat- Rampa- Rotary- Çorlu İnternet Sitesi- youngblood- Çorlu Palet- Çerkezköy Palet- Çorlu Prefabrik- Çorlu Sürücü Kursu- Çorlu Sandviç Panel- Şişli Avukat- Korona Test Kalemi- Çorlu Vinç- Çorlu Pimapen Tamiri-
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden