• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Kapalı Dosyadan veri al ve gönder

H

Hacı Bayram ÖZKAN

Katılım
24 Şubat 2009
Mesajlar
1,077
Excel Vers. ve Dili
2016
Selamün Aleyküm, iyi geceler arkadaşlar; Sitede araştırdım bir çok örneği olmasına rağmen bir türlü kapalı dosyadan Düşeyara Mantığı ile kapalı dosyadan veri alıp, tekrar buradaki verileri kapalı olan dosyaya nasıl gönderirim. Örnek Dosyalarım ekte bu belgeler D:\Belgelerim\Görev Klasörünün içinde isteğimi dosyalarda açıkladım. Kısaca şöyle Toplu Geçici Görev Yolluğu dosyasının sicil numarasına göre bilgiler gelsin, daha sonra bu bilgileri hesaplama yaptıktan sonra Geçici Görev Yolluğu Listesi 2017 dosyasının İcmal Sayfasına kayıt etsin yardımcı olursanız sevinirim. Teşekkür ederim.
 
Son düzenleme:
Hangi dosyalarda işlem yapılacak net değil!O yolladığınız klasörde 4 dosya var.
 
Selamün Aleyküm öncelikle bütün sitedeki arkadaşların kandili mübarek olsun;
Sayın Evren Hocam; Toplu Geçici görev yolluğu dosyamızı açtığımızda Adıyaman Sayfasının B6 ve devamında bulunan sicil numarasına göre veriler Personel Listesi dosyasının Liste sayfasından verileri alacak, gelin verilere bordro hesaplama yapacak, daha sonra bu veriler aynı dosya üzerinden verileri Listeye kaydet deyince Geçici Görev Yolluğu Listesi 2017 Dosyasının İcmal sayfasının A3 den başlamak üzere tekrar bu verileri buraya yazmasını istiyorum. 4. Dosya olan Geçici Görev Yolluğu bordrosunu dikkate almayın ben sizin yazacağınız koda göre bunu uyarlarım. Yani iki tane kod yazılacak, önce Düşeyara mantığı ile verilecek sicil numarasına göre Toplu Geçici Görev Yolluğu bordrosu üzerine gelecek gelen bu veriler ikinci kod ile tekrar Geçici Görev Yolluğu Listesi 2017 dosyasına kayıt edecek. Teşekkür ederim. Dosya üzerinde de açıklama var Hayırlı kandiller.
 
B sütununda sicil no girincemi , yoksa oradaki getir butonuna basıncamı verileri personel dosyasından getirecek?:cool:
 
Önce personel dosyasından veri alma konusunu bitirelim.
Ben bu konuyu yaptım.Yalnız Personel dosyasında EK GÖS. başlığından noktayı kaldırdım.
Başlıklarda nokta olmaması lazım.
B sütununa sicil no girerek denemeyi yapınız.
Bu bitince veri yollama konusuna bakıcam.
Dosya aşağıdaki linktedir.:cool:
Dosyaların hepsi ayni klasörün içinde olması lazım.:cool:

İstek üzerine dosyayı kaldırdım.

....
 
Dosyanız linktedir.:cool:

Dosyayı kaldırdım.

..
 
Sayın Evren bey, elinize sağlık güzel olmuş, birinci kodda
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B6:B" & Rows.Count)) Is Nothing Then Exit Sub
If Target.Value = "" Then Exit Sub
Range("C" & Target.Row & ":X" & Target.Row).ClearContents
Dim conn As Object, rs As Object
Set conn = CreateObject("Adodb.connection")
Set rs = CreateObject("adodb.recordset")
conn.Open ("Provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.Path & _
    "\PERSONEL LİSTESİ.xlsm;extended properties=""excel 12.0;hdr=yes""")
rs.Open "select * from [LİSTE$] where Sicili=" & Target.Value & ";", conn, 1, 1
If rs.RecordCount > 0 Then
    Cells(Target.Row, "C").Value = rs("Adı").Value
    Cells(Target.Row, "D").Value = rs("Soyadı").Value
    [COLOR="Red"]Cells(Target.Row, "E").Value = rs("Maaş D").Value & "/" & Cells(Target.Row, "E").Value = rs("Maaş K").Value[/COLOR]
    Cells(Target.Row, "F").Value = rs("EK GÖS").Value
    Cells(Target.Row, "G").Value = rs("Rütbesi").Value
End If
rs.Close
conn.Close
Kırmızı ile yazılı yeri unutmuşsunuz, bunu ben bu şekilde yazdım, ama yanlış diyor, yani personel listesinin M satırında bulunan Maaş D ile N satırında Bulunan Maaş K daki değerler için kırmızı kodu yazdım bunları E Sütununa 1/4'ü yazdıramadım. Buna bakar mısınız?
İkinci sorum her seferinde listeye kaydet deyince yani ikinci yazmış olduğunuz kodda sıra numarası ikinci veri girişinde her zaman 5'den başlıyor, (5,6,7 şeklinde oluyor) bu ya 1'den başlasın yada en son sıra numarasından devam etsin. Bu ikinci defa personel girince oluyor. yani bu listeyi bir defa kullanmayağım kusura bakmayın biraz fazla oldum ama vaktiniz olursa buna da bakarsanız sevinirim. Dua ile kalın iyi geceler.
 
Son düzenleme:
Kod: 
Cells(Target.Row, "E").Value = rs("Maaş D").Value  /  rs("Maaş K").Value
Böyle yazın.Eğer alanlardan birinde sıfır değeri varsa hata verir.
Satırda niye böyle sıra numarası verdi çözemedim maalesef.İsterseniz sıra no verme olayını kaldırabilirsiniz.
 
İlgili satırı aşağıdaki kırmızı satırla değiştiriniz.:cool:
Kod: 
For i = 6 To sonsat1
    [B][COLOR="Red"]sh.Cells(sat, "A").Value = WorksheetFunction.Max(sh.Range("A3:A" & sat)) + 1[/COLOR][/B]
 
For i = 6 To sonsat1
sh.Cells(sat, "A").Value = WorksheetFunction.Max(sh.Range("A3:A" & sat)) + 1

Abi bu kod çalıştı yani şöyle ekranda yine 5,6,7 diye devam ediyor ama listeye sıra numarasını yazarken doğru yazıyor önemli değil bu tamam.

Diğerinde; Cells(Target.Row, "E").Value = rs("Maaş D").Value / rs("Maaş K").Value
bunu böyle yazınca 1/4 yazacağı yere 0,25, 7/2 yazacağı yere 3,5 yazıyor, yani bölme işlemi yapar gibi yazıyor, oysa ben memur derece ve kademesi olan 1/2,2/3,4/3 gibi olmasını istiyorum. hücre değerini Metin yaptım yine böyle oldu bu düzelir mi? Teşekkürler
 
Evren bey; tamam hücreleri kesir yaptım oldu. Eline sağlık dua ile zahmet verdim. Sağlıcakla kal. Eksik olmayın Efendim.
 
Sayın Evren bey;
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B6:B" & Rows.Count)) Is Nothing Then Exit Sub
[COLOR="Yellow"]If Target.Value = "" Then[/COLOR] Exit Sub
Range("C" & Target.Row & ":X" & Target.Row).ClearContents
Dim conn As Object, rs As Object
Set conn = CreateObject("Adodb.connection")
Set rs = CreateObject("adodb.recordset")
conn.Open ("Provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.Path & _
    "\PERSONEL LİSTESİ.xlsm;extended properties=""excel 12.0;hdr=yes""")
rs.Open "select * from [LİSTE$] where Sicili=" & Target.Value & ";", conn, 1, 1
If rs.RecordCount > 0 Then
    Cells(Target.Row, "C").Value = rs("Adı").Value
    Cells(Target.Row, "D").Value = rs("Soyadı").Value
    Cells(Target.Row, "E").Value = rs("Maaş D").Value / rs("Maaş K").Value
    Cells(Target.Row, "F").Value = rs("EK GÖS").Value
    Cells(Target.Row, "G").Value = rs("Rütbesi").Value
End If
rs.Close
conn.Close
End Sub
Bu kodda TOPLU GEÇİCİ GÖREV YOLLUĞU Dosyasında B6:B17 arasını toplu silince "Run-time error '13' Type mismatch hatası verip ilgili satır sarı yanıyor. Neden? Bu kadar emek verdiniz bu hata neden? Saygılarımla
 
tarzanhaci' Alıntı:
Sayın Evren bey;
Bu kodda TOPLU GEÇİCİ GÖREV YOLLUĞU Dosyasında B6:B17 arasını toplu silince "Run-time error '13' Type mismatch hatası verip ilgili satır sarı yanıyor. Neden? Bu kadar emek verdiniz bu hata neden? Saygılarımla
Genişletmek için tıkla ...

kırmızı satırları ekleyin.:cool:
Kod: 
If Intersect(Target, Range("B6:B" & Rows.Count)) Is Nothing Then Exit Sub
[B][COLOR="Red"]on error resume next[/COLOR][/B]
If Target.Value = "" Then Exit Sub
[B][COLOR="red"]on error go to 0[/COLOR][/B]
Range("C" & Target.Row & ":X" & Target.Row).ClearContents
 
Sayın Orion1 on error go to 0 kısımdaki 0 ın anlamı nedir? Yukardaki kodlar içerisinde 0: şeklinde bir ifade görmedim. İlk kırmızı ifade hata verirse sonraki işleme geç oluyor. Genelde devam: şeklinde bir kod ile karşılaştım.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst