makro ile diğer sayfalardan veri alarak başka bir sayfada yan yan aktarılması

gezgin-49 · 23 Şubat 2007

arkadaşlar aşağıdaki makro ile 3 sayfadan alınan verilen sırasıyla başka bir sayfaya alt alta aktarılıyor, ama ben bu verilerin yan yana aktarılmasını istiyorum, aktarımın şöyle olması gerekiyor.
a)s1 sayfasındaki veriler s3 sayfasında a1 hücresine çocukları b1, c1, d1,....
hücrelerine de isimleri aktarmasını,
b)s2 sayfasında a2 hücresine gelini/damadı b2 hücresine de ismini aktarmasını,
a)s2 sayfasındaki torunların s3 sayfasında a3 hücresine torunlarıı b3, c3, d3
,.... hücrelerine de isimleri aktarmasını istiyorum, bu şekilde tüm verilerin aktarılması için aşağıdaki kodlarda nasıl bir değişiklik yapılması gerekiyor. eğer sorumu anlamadıysanız renkli olan kodların ne anlama geldiği konusunda ayrıntılı bilgi nasıl alabilirim, saygılar.

(bu kodlar Sayın leventm tarafından yazılmıştır, Sayın leventm başka bir işlem yapmak için bu kez verilerin yan yana aktarılması gerektiğinden böyle bir talebim oldu yardımlarınızı bekliyor, saygılar sunuyorum.)

Sub aktar()
Set s1 = Sheets("Zorunlu Bilgiler")
Set s2 = Sheets("Çocuklar (Evli Ölen)")
Set s3 = Sheets("miras hesapları")
Set s4 = Sheets("TORUNLAR (Evli Ölen)")
For a = 7 To s1.[f65536].End(3).Row
If s1.Cells(a, "g") = "sağ" Then
sat = s3.[c65536].End(3).Row + 1
s3.Cells(sat, "c") = s1.Cells(a, "f")
s3.Cells(sat, "b") = "çocuğu"
End If
Next
deg = Array("A4", "F4", "K4", "A19", "F19", "K19", "A34", "F34", "K34")
sutun = Array("D", "I", "N", "D", "I", "N", "D", "I", "N")
satir = Array(7, 7, 7, 22, 22, 22, 37, 37, 37)
For a = 0 To 8
If s2.Range(deg(a)) = "" Then GoTo 10
For b = 0 To 8
If s2.Cells(satir(a) + b - 1, sutun(a)) = "var" Then
sat = s3.[c65536].End(3).Row + 1
s3.Cells(sat, "c") = s2.Cells(satir(a) + b - 1, sutun(a)).Offset(0, -2)
s3.Cells(sat, "b") = "gelini/damadı"
End If
If s2.Cells(satir(a) + b, sutun(a)) = "sağ" Then
sat = s3.[c65536].End(3).Row + 1
s3.Cells(sat, "c") = s2.Cells(satir(a) + b, sutun(a)).Offset(0, -2)
s3.Cells(sat, "b") = "çocuğu"
End If
Next
10 Next
For a = 0 To 5
If s4.Range(deg(a)) = "" Then GoTo 20
For b = 0 To 8
If s4.Cells(satir(a) + b, sutun(a)) = "sağ" Then
sat = s3.[c65536].End(3).Row + 1
s3.Cells(sat, "c") = s4.Cells(satir(a) + b, sutun(a)).Offset(0, -2)
s3.Cells(sat, "b") = "torunu"
End IfNext
20 Next
MsgBox "Aktarıldı."
End Sub__________________

kombo · 23 Şubat 2007

Sn gezgin-49

Özel mesajla sormuş olduğunuz soruyu yeni gördüm. Bu konuda siz yardımcı olacak kapasitede bilgi sahibi değilim. Bende makroları hiç bilmiyorum.
Yine de mesajınızda sorduğunuz sorulardan bazılarının bildiğim kadarıyla cevapları şöyle;
For a = 7 To s1.[f65536].End(3).Row

For a aslında bir nevi makroda alan adı tanımlamak gibi.Normal çalışma sayfasında Alan Adı tanımladığımız gibi bu da makrocası

=7 To s1.[f65536].End(3).Row

7. satırdan Sheets("Zorunlu Bilgiler") "s.1 olarak makronun başında tanımlanmış" sayfasında F sütununda dolu en son satıra kadar olan alan.

GoTo 10

GO TO : İstenilen bir sayfaya yada satıra hızlı bir şekilde gitmek için kullanılır. Amaç makrodaki döngüyü bitirmek.
10 Eğer koşul sağlanmıyorsa 10 yazan satıra git. Bu işlemi herhalde 3 kere üstüste yaparsa bir alt satıra geçiyor.
Sizin örneğinizde mesela

If s4.Range(deg(a)) = "" Then GoTo 20
For b = 0 To 8
If s4.Cells(satir(a) + b, sutun(a)) = "sağ" Then
sat = s3.[c65536].End(3).Row + 1
s3.Cells(sat, "c") = s4.Cells(satir(a) + b, sutun(a)).Offset(0, -2)
s3.Cells(sat, "b") = "torunu"
End IfNext
20 Next
MsgBox "Aktarıldı."
IF "" (boş) değilse makro bir alt satıra geçer. Eğer boşsa GoTo 20 ile 20 Next yazan satır gider. Bu işlemi 3 kez üstüste tekrarlarsa MsgBox Yazan satıra geçer.

Diğer konuda yardımcı olamayacağım çünkü bende makro yazmayı bilmiyorum.

Eğer yazdıklarımda hata varsa , bilen arkadaşlar uyarsın bende öğreneyim sizi de yanlış yönlendirmeyeyim.

gezgin-49 · 26 Şubat 2007

makro ile başka sayfaya veri aktarımı

sayın leventm dosyayı ekte gönderiyorum, vba şifresi kenan' dır bu dosyada veri, çocuklar ve torunlar sayfasındaki verilerin daha önce miras tablosuna aktarımı sizin tarafınızdan alt alta yapılmıştı, bu kez başka bir sayfaya verilerin yan yana aktarılmasını istiyorum, örneğin
1-veri sayfasındaki sağ çocukların (F8:F22 arasındaki) isimlerinin sayfa2' de B1, C1, D1, E1,....
aktarılmasını, A1 hücresine de "çocukları" yazmasını,
2-çocuklar sayfasındaki her bir mirasçının (A4

18) arasındaki mirasçılar 1.ölü çocuğun mirasçıları, (F4:I18) arasındaki mirasçılar 2 çocuğun mirasçısı..... bu şekilde her bir çocuk için bir sütun ayırarak;
a)eğer birinci çocuğun eşi sağ ise genel sayfası A2 hücresine eşi, B2
hücresine ismini yazmasını,
b)sağ olan çocuklarını ise A3 hücresine "çocukları", B3,B4,B5,B6,B7
hücresine isem bu çocukların isimlerini yazmasını, bu şekilde tüm çocuklar
için ayrı satırlara veri girmesini,
3-Torunlar sayfasındaki verilerin de aynen çocuklar sayfasındaki gibi aktarılmasını istiyorum. yukarıdaki gibi verileri aktarabilirsem worde aktarma işlemini bağ yapıştır yöntemi ile kolayca yapabileceğimi sanıyorum. saygılar sunarım.

Levent Menteşoğlu · 27 Şubat 2007

Verileri Sayfa2 isimli sayfaya aktarıldığı kabul edilmiştir.

Birinci sorunuz için aşağıdaki kodu deneyin.

Kod:

Sub yatayaktar()
On Error Resume Next
Set s1 = Sheets("veri")
Set s2 = Sheets("sayfa2")
s2.[a1] = "&#199;ocuklar&#305;"
For a = 7 To s1.[f65536].End(3).Row
If s1.Cells(a, "g") = "sa&#287;" Then
sut = s2.Cells(1, 256).End(xlToLeft).Column + 1
s2.Cells(1, sut) = s1.Cells(a, "f")
End If
Next
s2.Select
MsgBox "Aktarma i&#351;lemi ba&#351;ar&#305;yla tamamland&#305;."
End Sub

Levent Menteşoğlu · 27 Şubat 2007

İkinci sorunuz için aşağıdaki kodu deneyin.

Kod:

Sub cocuklaryatayaktar()
Dim hucre As Range
Set s1 = Sheets("Çocuklar")
Set s2 = Sheets("sayfa2")
aralik = Array("B6:B18", "G6:G18", "L6:L18", "B24:B36", "G24:G36", "L24:L36", "B42:B54", "G42:G54", "L42:L54")
For a = 0 To 8
For Each hucre In s1.Range(aralik(a))
If hucre.Offset(0, 1) = "var" Then
s2.Cells(d + 2, "a") = "Eşi"
s2.Cells(d + 2, "b") = hucre
s2.Cells(d + 3, "a") = "Çocukları"
d = d + 2
End If
If hucre.Offset(0, 1) = "sağ" Then
s2.Cells(e + 3, c + 1) = hucre
End If
c = c + 1
Next
c = 0
e = e + 2
10 Next
s2.Select
MsgBox "Aktarma işlemi başarıyla tamamlandı."
End Sub

Üçüncü sorunuzuda benzer şekilde kendiniz yapabilirsiniz.

gezgin-49 · 27 Şubat 2007

Sayın Leventm işlemin birinci ayağı tamam ellerine sağlık

gezgin-49 · 27 Şubat 2007

leventm' Alıntı:

İkinci sorunuz için aşağıdaki kodu deneyin.

Kod:

Sub cocuklaryatayaktar()
Dim hucre As Range
Set s1 = Sheets("Çocuklar")
Set s2 = Sheets("sayfa2")
aralik = Array("B6:B18", "G6:G18", "L6:L18", "B24:B36", "G24:G36", "L24:L36", "B42:B54", "G42:G54", "L42:L54")
For a = 0 To 8
For Each hucre In s1.Range(aralik(a))
If hucre.Offset(0, 1) = "var" Then
s2.Cells(d + 2, "a") = "Eşi"
s2.Cells(d + 2, "b") = hucre
s2.Cells(d + 3, "a") = "Çocukları"
d = d + 2
End If
If hucre.Offset(0, 1) = "sağ" Then
s2.Cells(e + 3, c + 1) = hucre
End If
c = c + 1
Next
c = 0
e = e + 2
10 Next
s2.Select
MsgBox "Aktarma işlemi başarıyla tamamlandı."
End Sub

Üçüncü sorunuzuda benzer şekilde kendiniz yapabilirsiniz.

sayın leventm ikinci kısımda tamam ama bir husus daha var, mesela çocuklar sayfasında varsayalım 6 çocuk var 4 çocuk ölü olunca aktarma işleminde dördüncü çocuk yeri boş gösteriyor, burayı ölü çocuk varsa ona ayrılan hücre boş kalmadan o hücreye sağ olan diğer çocuğun yazılması gerekiyor, bunun için kodda nasıl bir düzeltme yapabiliriz. saygılar.

Levent Menteşoğlu · 27 Şubat 2007

Bunu anlayamadım. Aktarılmış şeklini gösteren bir örnek dosya eklermisiniz.

gezgin-49 · 28 Şubat 2007

makro kullanarak verilerin yan yana sıralanması

sayın leventm ekteki dosyada sayfa2 de açıklama yaptım. saygılar.

Levent Menteşoğlu · 28 Şubat 2007

Kodu aşağıdaki ile değiştirin.

Kod:

Sub cocuklaryatayaktar()
Dim hucre As Range
Set s1 = Sheets("Çocuklar")
Set s2 = Sheets("sayfa2")
aralik = Array("B6:B18", "G6:G18", "L6:L18", "B24:B36", "G24:G36", "L24:L36", "B42:B54", "G42:G54", "L42:L54")
For a = 0 To 8
For Each hucre In s1.Range(aralik(a))
If hucre.Offset(0, 1) = "var" Then
s2.Cells(d + 2, "a") = "Eşi"
s2.Cells(d + 2, "b") = hucre
s2.Cells(d + 3, "a") = "Çocukları"
d = d + 2
End If
If hucre.Offset(0, 1) = "sağ" Then
s2.Cells(e + 3, c + 2) = hucre
c = c + 1
End If
Next
c = 0
e = e + 2
10 Next
s2.Select
MsgBox "Aktarma işlemi başarıyla tamamlandı."
End Sub

gezgin-49 · 28 Şubat 2007

Sayın leventm müthişsiniz, sizi ayakta alkışlıyorum, siz bir harikasınız, Allah sizden razı olsun, proğramın en büyük ayağını sayenizde bitirmiş oldum, yazdığınız kodları teker teker inceleyeceğim, öncelikle For a = 0 To 8
d = d + 2
End If
If hucre.Offset(0, 1) = "sağ" Then
s2.Cells(e + 3, c + 2) = hucre
c = c + 1
kodlarını da biraz açıklarsanız belki yaptığınız işlemin mantığını anlamış olurum. saygılar sunuyor sonsuz teşekkürlerimi gönderiyorum. sağolun varolun...

Levent Menteşoğlu · 28 Şubat 2007

Rica ederim. Kodları kısaca açıklamaya çalışayım.

For a = 0 To 8 aralik dizisindeki hücre aralıkların ikinci döngüde tanımlanması içindir.

d = d + 2 "d" değişkenini her seferinde 2 arttırmak içindir. Bu verinin her döngüde iki atlayarak kaydedilmesini sağlar.

If hucre.Offset(0, 1) = "sağ" Then Döngü isimlerin olduğu sütunlarda çalışmaktadır, offset ile isimlerin olduğu sütundan bir sonraki sütundaki "sağ" kelimesinin kontrolü içindir.

s2.Cells(e + 3, c + 2) = hucre sağ çocukların isimlerini her seferinde bir sonraki sütuna ve döngü sonunda bir sonraki satıra kaydedilmesini sağlar.

c = c + 1 "c" değişkenini bir arttırmak içindir.

gezgin-49 · 28 Şubat 2007

ilginiz için teşekkür ederim, kodların ne işe yaradığını tam olarak anlayamadım, ama inşaallah en kısa zamanda çözeceğim, fakat sormadan duramayacağım, çoğu kodlara baktığımda "For a=0 To 8" döngü koduna rastlıyorum, acaba bu sabit bir döngü kodumudur, yoksa duruma göre değişebilirmi, (sizi çok meşgul ettiğimi biliyorum, isterseniz bu sorumu cevaplamayabilirsiniz, diğer arkadaşların size daha çok ihtiyacı olabilir.) size hayırlı çalışmalar, iyi geceler sunuyorum. kendinize iyi bakın, saygılar sunarım.

gezgin-49 · 1 Mart 2007

leventm' Alıntı:

Kodu aşağıdaki ile değiştirin.

Kod:

Sub cocuklaryatayaktar()
Dim hucre As Range
Set s1 = Sheets("Çocuklar")
Set s2 = Sheets("sayfa2")
aralik = Array("B6:B18", "G6:G18", "L6:L18", "B24:B36", "G24:G36", "L24:L36", "B42:B54", "G42:G54", "L42:L54")
For a = 0 To 8
For Each hucre In s1.Range(aralik(a))
If hucre.Offset(0, 1) = "var" Then
s2.Cells(d + 2, "a") = "Eşi"
s2.Cells(d + 2, "b") = hucre
s2.Cells(d + 3, "a") = "Çocukları"
d = d + 2
End If
If hucre.Offset(0, 1) = "sağ" Then
s2.Cells(e + 3, c + 2) = hucre
c = c + 1
End If
Next
c = 0
e = e + 2
10 Next
s2.Select
MsgBox "Aktarma işlemi başarıyla tamamlandı."
End Sub

sayın leventm üçüncüyü aktarmayı başaramadım. kodlamayı

Sub torunlaryatayaktar()
Dim hucre As Range
Set s1 = Sheets("torunlar")
Set s2 = Sheets("sayfa2")
aralik = Array("B6:B18", "G6:G18", "L6:L18", "B24:B36", "G24:G36", "L24:L36")
For a = 0 To 8
For Each hucre In s1.Range(aralik(a))
If hucre.Offset(0, 1) = "var" Then
s2.Cells(d + 2, "a") = "Eşi"
s2.Cells(d + 2, "b") = hucre
s2.Cells(d + 3, "a") = "torunları"
d = d + 2
End If
If hucre.Offset(0, 1) = "sağ" Then
s2.Cells(e + 3, c + 1) = hucre
End If
c = c + 1
Next
c = 0
e = e + 2
10 Next
s2.Select
MsgBox "Aktarma işlemi başarıyla tamamlandı."
End Sub

şeklinde yaptım
aralik = Array("B6:B18", "G6:G18", "L6:L18", "B24:B36", "G24:G36", "L24:L36")
hata veriyor, ayrıca aktarsa da veri sayfası ile çocuklar sayfasında aktarılan verileri silerek alt alta hep aynı verileri yazıyor. benim istediğim veri ve çocuklar sayfasındaki veriler aktarıldıktan sonra boş satır bırakmadan torunlar sayfasındaki verilerin de hemen alt satıra yerleşmesini istiyorum. saygılar.

Levent Menteşoğlu · 1 Mart 2007

Aşağıdaki şekilde deneyin. Yalnız bu kodu çalıştırmadan önce yukarıdaki iki kodun çalıştırılmış olması gerekir.

Kod:

Sub torunlaryatayaktar()
Dim hucre As Range
Set s1 = Sheets("torunlar")
Set s2 = Sheets("sayfa2")
aralik = Array("B6:B18", "G6:G18", "L6:L18", "B24:B36", "G24:G36", "L24:L36", "B42:B54", "G42:G54", "L42:L54")
For a = 0 To 8
For Each hucre In s1.Range(aralik(a))
If hucre.Offset(0, 1) = "var" Then
sonsat = s2.[a65536].End(3).Row + 1
s2.Cells(sonsat, "a") = "Eşi"
s2.Cells(sonsat, "b") = hucre
s2.Cells(sonsat + 1, "a") = "Torunları"
End If
If hucre.Offset(0, 1) = "sağ" Then
s2.Cells(sonsat + 1, c + 2) = hucre
c = c + 1
End If
Next
c = 0
10 Next
s2.Select
MsgBox "Aktarma işlemi başarıyla tamamlandı."
End Sub

gezgin-49 · 1 Mart 2007

leventm' Alıntı:

Aşağıdaki şekilde deneyin. Yalnız bu kodu çalıştırmadan önce yukarıdaki iki kodun çalıştırılmış olması gerekir.

Kod:

Sub torunlaryatayaktar()
Dim hucre As Range
Set s1 = Sheets("torunlar")
Set s2 = Sheets("sayfa2")
[COLOR="Red"]aralik = Array("B6:B18", "G6:G18", "L6:L18", "B24:B36", "G24:G36", "L24:L36"[/COLOR], "B42:B54", "G42:G54", "L42:L54")
For a = 0 To 8
For Each hucre In s1.Range(aralik(a))
If hucre.Offset(0, 1) = "var" Then
sonsat = s2.[a65536].End(3).Row + 1
s2.Cells(sonsat, "a") = "Eşi"
s2.Cells(sonsat, "b") = hucre
s2.Cells(sonsat + 1, "a") = "Torunları"
End If
If hucre.Offset(0, 1) = "sağ" Then
s2.Cells(sonsat + 1, c + 2) = hucre
c = c + 1
End If
Next
c = 0
10 Next
s2.Select
MsgBox "Aktarma işlemi başarıyla tamamlandı."
End Sub

sayın leventm yine aynı yerde hata verdi,
For Each hucre In s1.Range(aralik(a))
bir de aralık sayısı kırmızı işaretli yer L24:L36 da bitiyor yani torunlar sayfasında "B42:B54", "G42:G54", "L42:L54" hücrelerinde veri yok,

Levent Menteşoğlu · 1 Mart 2007

Orada hata vermesi için bir sebep yok, ben denedim gayet güzel çalıştı.

gezgin-49 · 1 Mart 2007

leventm' Alıntı:
Orada hata vermesi için bir sebep yok, ben denedim gayet güzel çalıştı.

sayın leventm ben hata yapmış olabilirim bir daha deneyeceğim, ellerinize sağlık Allah razı olsun, saygılar, sağolun varolun, sizde olmazsanız benim kahrımı kim çeker, tekrar ALLAH razı olsun,

makro ile diğer sayfalardan veri alarak başka bir sayfada yan yan aktarılması

gezgin-49

kombo

gezgin-49

Levent Menteşoğlu

Administrator

Levent Menteşoğlu

Administrator

gezgin-49

gezgin-49

Levent Menteşoğlu

Administrator

gezgin-49

Levent Menteşoğlu

Administrator

gezgin-49

Levent Menteşoğlu

Administrator

gezgin-49

gezgin-49

Levent Menteşoğlu

Administrator

gezgin-49

Levent Menteşoğlu

Administrator

gezgin-49