Kapalı dosyada buluan hesap nosu alma

[mars2]

İyi Günler;

İki adet excel çalışma kitabı bulunmakta 1. excel çalışma kitabında 1. sayfasında A sutununda dosya no ve B sutunda ise hesap no.su bulunmakta, ikinci excel çalışma kitabında ise A sutununda dosya nosunu yazdığımda B sutunundaki hücreine 1. excel çalışma kitabındaki dosya nosu karşısında hesap nosu yazacak makro ?

 

[Orion1]

Dosyanız ektedir.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim conn As Object, rs As Object
If Intersect(Target, Range("A2:A65536")) Is Nothing Then Exit Sub
If Target.Value = "" Then Exit Sub
Target.Offset(0, 1).Value = ""
Set conn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
conn.Open "Provider=Microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\Hesap no.xls;extended properties=""excel 8.0;hdr=yes"""
rs.Open "Select * from [Sayfa1$] where Dosya_No=" & Target.Value, conn, 1, 1
If rs.RecordCount > 0 Then
    rs.movefirst
    Target.Offset(0, 1).Value = rs(1).Value
End If
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
End Sub

 

[mars2]

Sayıon Evren Gizlen;

Cevabınz için teşekkürler, verdiğim örnekte dosya no kitabının 1 sayfasının B sutununda bulunan hesap nolarını M sutununa taşımam halinde kodda ne şekilde değişiklik olmamsı gerekir.

 

[Orion1]

Sayıon Evren Gizlen;

Cevabınz için teşekkürler, verdiğim örnekte dosya no kitabının 1 sayfasının B sutununda bulunan hesap nolarını M sutununa taşımam halinde kodda ne şekilde değişiklik olmamsı gerekir.

aşağıdaki satırı onun altındaki ile değiştirin.

Target.Offset(0, 1).Value = rs(1).Value

aşağıdaki ile değiştir.

cells(target.row,"M").value= rs(1).Value

 

[mars2]

Cevabınz için teşekkürler, özür dilerim ancak dosya no dosyasındaki değil hesap no kitabının 1 sayfasının B sutununda bulunan hesap nolarını M sutununa taşımam halinde kodda ne şekilde değişiklik olmamsı gerekir

 

[Orion1]

Sayıon Evren Gizlen;

Cevabınz için teşekkürler, verdiğim örnekte dosya no kitabının 1 sayfasının B sutununda bulunan hesap nolarını M sutununa taşımam halinde kodda ne şekilde değişiklik olmamsı gerekir.

Cevabınz için teşekkürler, özür dilerim ancak dosya no dosyasındaki değil hesap no kitabının 1 sayfasının B sutununda bulunan hesap nolarını M sutununa taşımam halinde kodda ne şekilde değişiklik olmamsı gerekir

Hangisi doğru?Bu iki açıklama biribiri ile çelişmiyormu?

 

[mars2]

Sayın Evren Gizlen;
Yanlışlıkla Dosya No kitabındaki yazmıştım. Ancak, doğrusu Hesap nosundaki olacaktır.
Hesap No kitabındaki B sutununda bulunan hesap nolarının M sutununa taşımak istiyorum. Yardımlarınız için şimdiden teşekkürler.

 

[Orion1]

Sayın Evren Gizlen;
Yanlışlıkla Dosya No kitabındaki yazmıştım. Ancak, doğrusu Hesap nosundaki olacaktır.
Hesap No kitabındaki B sutununda bulunan hesap nolarının M sutununa taşımak istiyorum. Yardımlarınız için şimdiden teşekkürler.

O sütunu başlığı ile M sütununa taşıyınız.
Ve kodadaki ilgili sütunu aşağıdaki
ile değiştiriniz.

Target.Offset(0, 1).Value = rs("Hesap_No").Value

 

[mars2]

Sayın Evren Gizlen;
Cevaplarınız için teşekkürler. Sizden konu hakkında biraz daha yardım alabilirsem sevinirim.
Bilgisayarımın D bölümünde Hesap takip klasörü bulunmakta, bu klasörün içinde Bankaya yatanlar ve hesaplar klasörü bulunmakta,
Bankaya yatanlar klasöründe yıllar itibari ile düzenlenmiş örneğimizde 2010 çalışma kitabı ve bu kitapta aylar ayrı ayrı sayfalarda düzenlenmiştir.
Hesaplar klasöründe ise bankaya açılan kitabının “B” sutunun da dosya No.su “N” sutunun da ise açılan hesaplara hesap no.ları kaydedilmiştir.
Yapmak istediğim : 2010 çalışma kitabında hangi ayda hesap para yatırılması halinde B sutununa dosya no.su yazdığımda H sutunun da hesap no.su yazmak istiyorum. Bununla ilgili makro nedir?

Örnek: 2010 çalışma kitabının ocak

B sutunu H sutunu

8356104 2940

 

[Orion1]

Dosyanız ektedir.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim conn As Object, rs As Object
Dim sBrowsePath, sBrowseFilter, oBrowseDialog
If Intersect(Target, [B2:B65536]) Is Nothing Then Exit Sub
Cells(Target.Row, "H").Value = ""
If Target.Value = "" Then Exit Sub
Set conn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.recordset")
conn.Open "provider=microsoft.jet.oledb.4.0;data source=D:\Hesap takip" _
& "\Hesaplar\Bankaya Açılan Hesap Listesi.xls;extended properties=""excel 8.0;hdr=yes"""
rs.Open "select Dosya_No,Hesap_No from [Sayfa1$] where Dosya_No=" & Target.Value, conn, 1, 1
If rs.RecordCount > 0 Then
    Cells(Target.Row, "H").Value = rs("Hesap_No")
    Else
    MsgBox "[ " & Target.Value & " ] dosya no bulunamdı!", vbCritical, "UYARI"
End If
rs.Close: conn.Close
Set rs = Nothing
Set conn = Nothing
End Sub