Tablodan tabloya veri aktarma

[obenim]

merhaba,

şimdiden herkese yardımlarından oturu tesekkur ederim. benim soru su sekilde:

surekli olarak cok satırlı, içinde oldukca fazlaca veri olan dosyalarla calısıyorum. ekte vereceğim iki ornek dosya arasında uygun sartlar sağlanırsa bu veriyi aktar komutu vermek istiyorum ancak nasıl yapacağımı bilemiyorum. konuyu daha acıkca belirmek gerekirse, ekte yer alan kitap 1 deki Genel Borç hanesine, eğer kitap 2 de kitap 1 deki musteri kodu var ise kitap 2 deki o musteri koduna ait genel borç hucresindeki veriyi al, kitap 1 deki o musteri koduna ait satırdaki genel borç hanesine yaz.

anlatması kolay ama yapmaya gelince beni cok astı. yardımlarınızı rica ediyorum.

 

[Mahmut Kök]

Sadece Kitap1'i açın ve aşağıdaki kodları çalıştırın. Kitap2'yi seçmeniz için ekran çıkacak, oradan Kitap2'yi seçin.

Sub borc_al()
MsgBox "Verilerin alınacağı excel belgesini seçmek için tamam düğmesine basınız.", , "hedef"
dosya = Application.GetOpenFilename
If dosya = False Then
MsgBox "dosya seçilmedi"
Exit Sub
End If
Set ktp1 = ThisWorkbook
Set ktp2 = Workbooks.Open(dosya)
Set s1 = ktp1.Sheets(1)
Set s2 = ktp2.Sheets(1)
 
For a = 2 To s1.Range("a65536").End(3).Row
Set bak = s2.Range("a1:a65536").Find(s1.Cells(a, "a") * 1, lookat:=xlWhole)
If Not bak Is Nothing Then
B = B + 1
s1.Cells(a, "c") = s2.Cells(bak.Row, "c")
Set bak = Nothing
End If
Next
ktp2.Close False
MsgBox "KARŞILAŞTIRMA YAPILDI " & B & " ADET VERİ EKLENDİ"
End Sub

 

[obenim]

Sadece Kitap1'i açın ve aşağıdaki kodları çalıştırın. Kitap2'yi seçmeniz için ekran çıkacak, oradan Kitap2'yi seçin.

Sub borc_al()
MsgBox "Verilerin alınacağı excel belgesini seçmek için tamam düğmesine basınız.", , "hedef"
dosya = Application.GetOpenFilename
If dosya = False Then
MsgBox "dosya seçilmedi"
Exit Sub
End If
Set ktp1 = ThisWorkbook
Set ktp2 = Workbooks.Open(dosya)
Set s1 = ktp1.Sheets(1)
Set s2 = ktp2.Sheets(1)
 
For a = 2 To s1.Range("a65536").End(3).Row
Set bak = s2.Range("a1:a65536").Find(s1.Cells(a, "a") * 1, lookat:=xlWhole)
If Not bak Is Nothing Then
B = B + 1
s1.Cells(a, "c") = s2.Cells(bak.Row, "c")
Set bak = Nothing
End If
Next
ktp2.Close False
MsgBox "KARŞILAŞTIRMA YAPILDI " & B & " ADET VERİ EKLENDİ"
End Sub

yardımlarınız için cok tesekkurler. bu calısmayı Kitap 1deki tabloya ekte gorulduğu gibi D sutunu nu da eklersem kodu nasıl revize etmem gerekiyor. D sutunu kitap 2 de de mevcut.

 

[Mahmut Kök]

Koda, aşağıdaki satırı ilave ediniz.

.....
.....
B = B + 1
s1.Cells(a, "c") = s2.Cells(bak.Row, "c")
[B][COLOR=red]s1.Cells(a, "d") = s2.Cells(bak.Row, "d")[/COLOR][/B]
Set bak = Nothing
End If
.....
.....

 

[obenim]

Koda, aşağıdaki satırı ilave ediniz.

.....
.....
B = B + 1
s1.Cells(a, "c") = s2.Cells(bak.Row, "c")
[B][COLOR=red]s1.Cells(a, "d") = s2.Cells(bak.Row, "d")[/COLOR][/B]
Set bak = Nothing
End If
.....
.....

kod maalesef calısmadı. ekteki hata ile karsılastık.

 

[rainmaker29]

arkadaşlqar buna ek olarak bişey sormak istiyorum. kitap 1 deki makroyu çalıştırıp kitap 2 deki bütün verileri sadece kopyalayıp kitap1e yapıştırması için nasıl bi makro yazılır.

Sub aktar()
MsgBox "Verilerin alınacağı excel belgesini seçmek için tamam düğmesine basınız.", , "hedef"
dosya = Application.GetOpenFilename
If dosya = False Then
MsgBox "dosya seçilmedi"
Exit Sub
End If
Set ktp1 = ThisWorkbook
Set ktp2 = Workbooks.Open(dosya)
Set s1 = ktp1.Sheets(k-z)
Set s2 = ktp2.Sheets(k-z)

gerisi nasıl olacak acaba.yardımlarınız bekliyorum. veya baştan yazabilirsiniz

 

[rainmaker29]

yardımcı olacak yokmuydu arkadaşlar. rica ediyorum.