Kapalı dosyadan tapu bilgilerini alma

[mars2]

İyi Günler;

Kayıt adlı çalışma kitabında yıllar sayfasında bulunan tabloya ekli Liste kitabından bilgi aktarmak istiyorum.

Yıllar sayfasının B10 hücresine isim yazdığımda, Liste kitabın 1. sayfasındaki bilgiler aktarmak istiyorum. Buna ilişkin örnek ektedir.

Yardımlarınız için şimdiden teşekkürler.

 

[Korhan Ayhan]

Selamlar,

"Kayıt" isimli dosyanızdaki "yıllar" isimli sayfanızın kod bölümüne aşağıdaki kodu uygulayınız.

Kodun çalışması için iki dosyanın aynı bölümde olması gerekiyor.

Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Dosya_Yolu As String, Son As Long, X As Long, Say As Integer
    Dim Veri1 As String, Veri2 As String
    
    On Error GoTo Son
    
    If Intersect(Target, Range("B10")) Is Nothing Then Exit Sub
    If Target <> "" Then
    
        Range("B2:B8").ClearContents
        Range("D2:E8").ClearContents
        Range("B11:E11").ClearContents
        
        Dosya_Yolu = ThisWorkbook.Path & "\[liste.xls]Sayfa1"
        
        Son = Application.ExecuteExcel4Macro("COUNTA('" & Dosya_Yolu & "'!C1)")
        Veri1 = UCase(Replace(Replace(Target.Text, "ı", "I"), "i", "İ"))
        
        For X = 2 To Son
            Veri2 = UCase(Replace(Replace(Application.ExecuteExcel4Macro("'" & Dosya_Yolu & "'!R" & X & "C8"), "ı", "I"), "i", "İ"))
            If Veri1 = Veri2 Then
            Range("B2") = Application.ExecuteExcel4Macro("'" & Dosya_Yolu & "'!R" & X & "C2")
            Range("B5") = Application.ExecuteExcel4Macro("'" & Dosya_Yolu & "'!R" & X & "C3")
            Range("B6") = Application.ExecuteExcel4Macro("'" & Dosya_Yolu & "'!R" & X & "C4")
            Range("D3") = Application.ExecuteExcel4Macro("'" & Dosya_Yolu & "'!R" & X & "C7")
            Range("D7") = Application.ExecuteExcel4Macro("'" & Dosya_Yolu & "'!R" & X & "C5")
            Range("D8") = Application.ExecuteExcel4Macro("'" & Dosya_Yolu & "'!R" & X & "C6")
            Say = Say + 1
            Exit For
            End If
        Next
    
        If Say = 0 Then
            MsgBox Veri1 & " isimli kayıt bulunamadı !", vbExclamation
        End If
    End If

Son:
End Sub

 

[mars2]

Sayın Korhan Ayhan
Cevabınız için teşekkürler. verilen kodları uygulamada çalıştı. ancak, Liste kitaptaki ismi N sutunun alınca çalışmadı. Neden olabilir.

Son = Application.ExecuteExcel4Macro("COUNTA('" & Dosya_Yolu & "'!N1)") düzeltmeme rağmen.
Teşiekkürler.

 

[Korhan Ayhan]

Selamlar,

Yanlış yeri düzeltmişsiniz.

ExecuteExcel4Macro özelliği R1C1 başvuru stiliyle çalışır. Sizin düzelltiğiniz bölümde "C" harfi aslında Column (Sütun) anlamına gelmektedir. Aynı şekilde "R" harfide Row (Satır) anlamına gelmektedir.

R1C1 komutu aslında A1 hücresini ifade etmektedir.
R1C2 komutu aslında B1 hücresini ifade etmektedir.


Kod içinde geçen aşağıdaki satırdaki 8 değerini 14 olarak düzeltin.

Veri2 = UCase(Replace(Replace(Application.ExecuteExcel4Macro("'" & Dosya_Yolu & "'!R" & X & "C[COLOR=red]8[/COLOR]"), "ı", "I"), "i", "İ"))

 

[mars2]

Sayın Korhan Ayhan;
Cevabınız için teşekkürler istediğim gib oldu.
aynı tabloyu 2 sayfada bu kez B2 hücresindeki Taşınmaz no ile yapmak istedim ve aşağıdaki kodu

If Intersect(Target, Range("B10")) Is Nothing Then Exit Sub
olarak düzeltmeme rağmen çaılmadı neden olabilir?
If Intersect(Target, Range("B2")) Is Nothing Then Exit Sub