Excelden Tapu Alan Aktarılması (Netcad Makro)

Makro Hakkında:

Excel’de xls formatlı dosyanızda 1. sütuna parsel numarası,2.sütuna tapu alanını yazınız. Parsel numaralarının netcad projeniz ile aynı olmasına dikkat ediniz. Böylece excele yazdığınız tapu alanları netcad projenizdeki alanlara yazdırılır.

  • Karşınıza gelen ekrandan excel dosyasını seçiniz. Parsel Adı Sütununa, parsel adı hangi kolonda ise onun numarasını, Tapu Alanı Hangi Sütunda ise onun numarasını yazınız. Örnek dosya aşağıdaki gibidir.
  • Makroda Üzerinde Çalıştığımız Gelişmeler:
    • Şu anlık üzerinde çalıştığımız bir gelişme bulunmamaktadır. Kullanıcılardan gelen istekler ve editörlerimizin çalışmaları ile olası gelişmeler yayımlanacaktır. Bizi takip ediniz.
  • Etiketler: Basit düzey makro, Netcad, Makro, Pratik Netcad, Netcad Araçları, Netcad tabaka, netcad seçim, Pratik Netcad, Netcadde nasıl yapılır,netcad menü, netcad araç, nvb, ücretsiz makro, harita makro,tapu alan, aktarma, Excel, Netcad Excel ilişkisi

Uyarılar:

  • Exceldeki sütun adları ile kullanıcı formundaki sütun adlarının aynı olmasına dikkat ediniz.
  • Bu makro ile en fazla 50bin satır excel satırı okunabilir.
  • Exceldeki parsel no ile projedeki parsel no eşleşmesi durumunda Önceki tapu alanı silinir ve bu işlem geri alınmaz
  • Excel dosyasındaki parsel no sütunundaki tüm parseller projenizde taranacak. Bu durumda
    • Bir parselden aynı isimli birden fazla olması durumunda tapu alanı hatası olacağını unutmayınız
    • Tapu alanı sütununda sayı olmayan karakter kullanmayınız. Ondalık ayracı olarak nokta kullanınız.
    • Excel ile netcad projesinde eşleşmeyen alanlarda tapu alanı değiştirme yapılmayacaktır. Eski tapu alanı aynı kalacaktır.
  • Netcad makrolarında hiçbir metni veya karakteri değiştirmeyiniz. Aksi halde makro işlevsiz hale gelebilir veya hatalı işlev ile karşılaşabilirsiniz.

İndirme Linkleri:

İndirme Linki-1: Google Drive ( Harita Akademi )

Makro Açık Kaynak Kodu:

'' www.sabangul.com.tr Web Sayfasından İndirilmiştir
' Şaban GÜL , Harita Mühendisi
' Her Türlü Hata, İstek ve Öneriler İçin 
' haritaakademi@gmail.com veya sagulnet@gmail.com
' adresine durumu anlatan bir e-posta gönderiniz.

Sub Main
 with netcad

Dim i
 dim j
 dim o
 dim SEL
 dim xls
 dim xlspath
 dim alan
 dim DEG
 dim CL
 dim bd
 DIM U,V,R,W
 dim ruhangul
 dim elifyaren
 DIM NO(50000,2)
 DEG = ""
 CL=0:U=0:R=0
 set xls = CreateObject("excel.application")







set BD = Netcad.NewBDialog("Tapu Alanının Excelden Aktarımı [Harita Akademi, Şaban GÜL]")
 BD.GetFileName "item1","Aktarım Yapılacak Excel Dosyası Seçiniz:","","Excel Dosyalari|*.xls|Tum Dosyalar|*.*","xls"
 BD.Getcombo "item2","Parsel Numarası Hangi Sütunda Bulunuyor ? ","A|B|C|D|E|F|G|H|I|J|K|L|M|N|O|P|Q|R|S|T|U|V|W|X|Y|Z" ,0
 BD.Getcombo "item3","Tapu Alanı Hangi Sütunda Bulunuyor ? ","A|B|C|D|E|F|G|H|I|J|K|L|M|N|O|P|Q|R|S|T|U|V|W|X|Y|Z" ,1
 BD.Getcheck "item4","Tapu Alanı Sıfır ise Hesap Alanını Yazdır" ,1
 if BD.showmodal then
 xlspath = BD.ValueByName("item1")
 RUHANGUL=BD.ValueByName("item4")
 else
 exit sub
 end if

dim saban,ruhan

saban= BD.ValueByName("item2")
 ruhan= BD.ValueByName("item3")

saban=1
 ruhan=2

if BD.ValueByName("item2")="A" then saban=1
 if BD.ValueByName("item2")="B" then saban=2
 if BD.ValueByName("item2")="C" then saban=3
 if BD.ValueByName("item2")="D" then saban=4
 if BD.ValueByName("item2")="E" then saban=5
 if BD.ValueByName("item2")="F" then saban=6
 if BD.ValueByName("item2")="G" then saban=7
 if BD.ValueByName("item2")="H" then saban=8
 if BD.ValueByName("item2")="I" then saban=9
 if BD.ValueByName("item2")="J" then saban=10
 if BD.ValueByName("item2")="K" then saban=11
 if BD.ValueByName("item2")="L" then saban=12
 if BD.ValueByName("item2")="M" then saban=13
 if BD.ValueByName("item2")="N" then saban=14
 if BD.ValueByName("item2")="O" then saban=15
 if BD.ValueByName("item2")="P" then saban=16
 if BD.ValueByName("item2")="Q" then saban=17
 if BD.ValueByName("item2")="R" then saban=18
 if BD.ValueByName("item2")="S" then saban=19
 if BD.ValueByName("item2")="T" then saban=20
 if BD.ValueByName("item2")="U" then saban=21
 if BD.ValueByName("item2")="V" then saban=22
 if BD.ValueByName("item2")="W" then saban=23
 if BD.ValueByName("item2")="X" then saban=24
 if BD.ValueByName("item2")="Y" then saban=25
 if BD.ValueByName("item2")="Z" then saban=26



if BD.ValueByName("item3")="A" then ruhan=1
 if BD.ValueByName("item3")="B" then ruhan=2
 if BD.ValueByName("item3")="C" then ruhan=3
 if BD.ValueByName("item3")="D" then ruhan=4
 if BD.ValueByName("item3")="E" then ruhan=5
 if BD.ValueByName("item3")="F" then ruhan=6
 if BD.ValueByName("item3")="G" then ruhan=7
 if BD.ValueByName("item3")="H" then ruhan=8
 if BD.ValueByName("item3")="I" then ruhan=9
 if BD.ValueByName("item3")="J" then ruhan=10
 if BD.ValueByName("item3")="K" then ruhan=11
 if BD.ValueByName("item3")="L" then ruhan=12
 if BD.ValueByName("item3")="M" then ruhan=13
 if BD.ValueByName("item3")="N" then ruhan=14
 if BD.ValueByName("item3")="O" then ruhan=15
 if BD.ValueByName("item3")="P" then ruhan=16
 if BD.ValueByName("item3")="Q" then ruhan=17
 if BD.ValueByName("item3")="R" then ruhan=18
 if BD.ValueByName("item3")="S" then ruhan=19
 if BD.ValueByName("item3")="T" then ruhan=20
 if BD.ValueByName("item3")="U" then ruhan=21
 if BD.ValueByName("item3")="V" then ruhan=22
 if BD.ValueByName("item3")="W" then ruhan=23
 if BD.ValueByName("item3")="X" then ruhan=24
 if BD.ValueByName("item3")="Y" then ruhan=25
 if BD.ValueByName("item3")="Z" then ruhan=26





set BD = Nothing
 xls.workbooks.open(xlspath)
 xls.range("A1").select

FOR U=1 TO 100000
 CL=CL+1
 NO(U,1)="*" & XLS.CELLS(U,saban)
 NO(U,2)= XLS.CELLS(U,ruhan)
 IF NO(U,2)="" THEN NO(U,2)=0
 IF NO(U,1)="*" THEN U=100000
 NEXT
 xls.quit





MSGBOX CL-1 & " Adet Parsel Excel Dosyasından Başarıyla Okundu. Lütfen İşlem Görecek Parselleri Seçiniz."





set SEL = .NewSelectionSet
 set o = .NewObject





if SEL.SELECT("CokluDogru Objelerini Seçiniz...",array(opline)) then

for i = 0 to SEL.NE-1
 j = SEL.GetSelectedObject(i, o)
 alan = o.pname
 ' MSGBOX ":" & alan & ":"
 on error resume next
 FOR V=1 TO CL
 W=NO(V,1)
 if W ="*" & alan then
 o.tarea = NO(V,2)
 if BD.ValueByName("item4")= 1 and o.tarea=0 then
 o.tarea=o.area
 end if
 .putobject j, o
 R=R+1
 'MSGBOX alan & " : " & NO(V,1) & " : " & NO(V,2)
 V=U
 end if
 NEXT

next
 SEL.RedrawAndRewind
 end if

set SEL = nothing
 set o = nothing
 end with

MSGBOX R & " adet Parselin Tapu Alanı Değiştirildi."

end sub

 

Yazar: Şaban GÜL

Amacımız herkese yardımcı olabilmek. Haritacılık ile sınırlı kalmayıp birçok sektöre girmeye RAMAK kaldı :)

7 thoughts on “Excelden Tapu Alan Aktarılması (Netcad Makro)

    Ali ERYİĞİT

    (4 Ekim 2017 - 07:48)

    Merhaba; makroyu Netcad 5.1 ve Netcad 7.0 versiyonlarında denedim. Tapu alanı 0 (sıfır) olmamasına rağmen tapu alanı sütununa hesap alanını aktarıyor. Nasıl bir problem olabilir.

    ULAŞ ÖZER

    (4 Nisan 2018 - 13:32)

    Her durumda tapu alanı yerine hesap alanını yazıyor. Ne denediysem olmadı

      Şaban GÜL

      (6 Nisan 2018 - 09:28)

      Kesinlikle olamaz. Formüllerde tapu alanı yazılmış ve zaten hesap alanını istesenizde makrolarla vs. değiştiremezsiniz, hesap alanının değişmesi için grafik ekrandan değiştirmeniz gerekir.

    Akın

    (21 Nisan 2018 - 14:24)

    bendede hesap alanı direk tapu alana yazmakta. okuduğu excel sayfasına göre işlem yapmamakta

      Yns GEDİK

      (2 Mart 2020 - 15:32)

      bu sorunu çözebildinmiz mi ben de ne yaptıysam tapu alanını yazdıramadım. Her denemem de hesap alanını yazıyor netcad tapu alanı kısmına

        Şaban GÜL

        (22 Mayıs 2020 - 09:39)

        Çalışması gerekiyor. XLS formatında kaydederek deneyiniz

    SÜLEYMAN SAKA

    (4 Kasım 2019 - 09:55)

    HOCAM DEDİKLERİNE KATILIYORUM EXCELDEN ÇEKMİYOR SADECE HESAP ALANI TAPU ALANI YAPIYOR.

Bir cevap yazın

E-posta hesabınız yayımlanmayacak. Gerekli alanlar * ile işaretlenmişlerdir

This site uses Akismet to reduce spam. Learn how your comment data is processed.