• DİKKAT

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

Kaynak dosyadan verileri Shettlere aktarmak

E

essenkaya

Katılım
31 Mart 2011
Mesajlar
13
Excel Vers. ve Dili
Office 2010 TR
1 sayfamdaki kaynak bilgileri oluşturduğum diğer sayfalara atmak istiyorum.
Şöyleki;
Kaynak raporumda B sutunundaki karışık bilgilerden yola çıkarak her grup bilgi için ayrı sheet oluşturdum.
1. sayfada B3 sutunundaki değer1 "abc" ise ve F3 deki değer5 ile eşit değilse abc sayfasındaki formül yazdığım ekrana çıkmalı.
Aynı şekilde 1. sayfada B3 sutunundaki değer1 "dfe" ise ve F3 deki değer5 ile eşit değilse dfe sayfasındaki formül yazdığım ekrana çıkmalı.
Burada değer1den filtreleme yapıp, değer2,değer3,değer4 ve değer5 sutunlarınıda ilgili sayfalara çıkarmak istiyorum...
yazarken bile karıtırdım...yardımlarınızı rica ediyorum.

Örnek dosya ektedir
 

Ekli dosyalar

kusura bakmayın belki benden kaynaklanıyordur.
anlayamadım biraz daha açıklama ekler misiniz
örnek dosya içine yaparsanız daha net bir şekilde yardımcı olmaya çalışırım
 
ihsan bey siz bir harikasınız :)))
 
hayır mesaja verdiğiniz cevap çok nazik olmuş. ercan beyle olan konudan sonra bu bir örnek olmuş ercan beye ondan harikasınız dedim :)
 
neyse artık essenkaya arkadaşımızın konusuyla biraz ilgileneyim bakalım çözebilecekmiyiz.
 
ulutanas' Alıntı:
hayır mesaja verdiğiniz cevap çok nazik olmuş. ercan beyle olan konudan sonra bu bir örnek olmuş ercan beye ondan harikasınız dedim :)
Genişletmek için tıkla ...

sadece anlamadığım için öyle yazdım belki de kafam orda takılı kalmıştır diye.
siz bakın eğer ki anladığınız yerleri anlatırsanız bende elimden geldiğince yardımcı olurum
 
öncelikle ilginiz için teşekkür ederim.
Yazarken istediğim kurguyu net tarif edemedim aslında...kurgu çok basit
Tüm kaynak 1. sayfada ve B sutununda..
1. sayfada B sutununda gelecek değerleri biliyorum.karışık gelen bu verilere göre sayfalar oluşturdum.
istediğim oluşturduğum sayfalara gelecek veriyi 1. sayfadan yakalamak ve almak.
Burda tek sorun 1. sayfadaki B ile F değerleri aynı ise gelmesini istemiyorum. Hatta B ve F sutunlarındaki ilk üç karakteri ya da ilk 5 karakteri aynı olursa gelmesini istemiyorum.
 
sayın essenkaya anladığım kadarıyla değer 1 ve değer5 e girilecek 4 seçenek var bunlar abc - def-ghi-klm eğer değer 1 ve değer5 dekiler birbiriyle aynı ise aynı olan harflerin kendi sayfasına aktarımını istiyorsunuz doğrumu anlamışım. Eğer böyle bir şey istiyorsanız veya yanlış anladıysam daha detaylı bir açıklama yaparsanız yardımcı olabilirim. iyi çalışmalar.
 
Öncelikle bahsettiğiniz şeyin tersini istiyorum.

detay yazıyorum şimdi.
 
Tekrar merhaba,
ekli dosyada 2. sayfada hangi bilgiyi istediğimi anlatmaya çalıştım.
 

Ekli dosyalar

ekdeki dosyada yazdığınız sorunuzu birde ben soru ekleyim. :)

Bu alana şu bilginin gelmesini istiyorum . 1. safyada B3 de ABC yazıyor ve F3 de ABC den farklı bir şey yazıyorsa(B3 ile F3 eşit değil ise) B3 deki bilgiyi buraya getir. demişsiniz

peki b3 ile f3 aynı ise bahsettiğiniz alanda ne yazmasını istiyosunuz. boşmu kalsın yoksa bir metin aktaralımmı
 
Hocam,
Eğer 1. sayfada B3 ile F3 aynı ise ABC sayfasına bu satır gelmeyecek.
 
essenkaya' Alıntı:
Hocam,
Eğer 1. sayfada B3 ile F3 aynı ise ABC sayfasına bu satır gelmeyecek.
Genişletmek için tıkla ...

merhaba
bu kod'u boş bir module kopyalayın ardından çalıştırın.
Kod: 
Option Explicit
Sub eşitsiz_aktar()
Dim ts, kaplan, abc, def, ghi, klm
kaplan = MsgBox("Eşit Olmayanları Aktarayım Mı_?", vbYesNo, "Onay")
If kaplan = vbNo Then Exit Sub
Sheets("abc").Range("B3:F65536").ClearContents
Sheets("def").Range("B3:F65536").ClearContents
Sheets("ghi").Range("B3:F65536").ClearContents
Sheets("klm").Range("B3:F65536").ClearContents
abc = 3: def = 3: ghi = 3: klm = 3
For ts = 3 To Sheets("Sayfa1").Cells(65536, "B").End(xlUp).Row
If Sheets("Sayfa1").Cells(ts, "B") <> Sheets("Sayfa1").Cells(ts, "F") And _
Sheets("Sayfa1").Cells(ts, "B") = "abc" Then
Sheets("abc").Cells(abc, "B") = Sheets("Sayfa1").Cells(ts, "B")
Sheets("abc").Cells(abc, "C") = Sheets("Sayfa1").Cells(ts, "C")
Sheets("abc").Cells(abc, "D") = Sheets("Sayfa1").Cells(ts, "D")
Sheets("abc").Cells(abc, "E") = Sheets("Sayfa1").Cells(ts, "E")
Sheets("abc").Cells(abc, "F") = Sheets("Sayfa1").Cells(ts, "F")
abc = abc + 1
ElseIf Sheets("Sayfa1").Cells(ts, "B") <> Sheets("Sayfa1").Cells(ts, "F") And _
Sheets("Sayfa1").Cells(ts, "B") = "def" Then
Sheets("def").Cells(def, "B") = Sheets("Sayfa1").Cells(ts, "B")
Sheets("def").Cells(def, "C") = Sheets("Sayfa1").Cells(ts, "C")
Sheets("def").Cells(def, "D") = Sheets("Sayfa1").Cells(ts, "D")
Sheets("def").Cells(def, "E") = Sheets("Sayfa1").Cells(ts, "E")
Sheets("def").Cells(def, "F") = Sheets("Sayfa1").Cells(ts, "F")
def = def + 1
ElseIf Sheets("Sayfa1").Cells(ts, "B") <> Sheets("Sayfa1").Cells(ts, "F") And _
Sheets("Sayfa1").Cells(ts, "B") = "ghi" Then
Sheets("ghi").Cells(ghi, "B") = Sheets("Sayfa1").Cells(ts, "B")
Sheets("ghi").Cells(ghi, "C") = Sheets("Sayfa1").Cells(ts, "C")
Sheets("ghi").Cells(ghi, "D") = Sheets("Sayfa1").Cells(ts, "D")
Sheets("ghi").Cells(ghi, "E") = Sheets("Sayfa1").Cells(ts, "E")
Sheets("ghi").Cells(ghi, "F") = Sheets("Sayfa1").Cells(ts, "F")
ghi = ghi + 1
ElseIf Sheets("Sayfa1").Cells(ts, "B") <> Sheets("Sayfa1").Cells(ts, "F") And _
Sheets("Sayfa1").Cells(ts, "B") = "klm" Then
Sheets("klm").Cells(klm, "B") = Sheets("Sayfa1").Cells(ts, "B")
Sheets("klm").Cells(klm, "C") = Sheets("Sayfa1").Cells(ts, "C")
Sheets("klm").Cells(klm, "D") = Sheets("Sayfa1").Cells(ts, "D")
Sheets("klm").Cells(klm, "E") = Sheets("Sayfa1").Cells(ts, "E")
Sheets("klm").Cells(klm, "F") = Sheets("Sayfa1").Cells(ts, "F")
klm = klm + 1
End If
Next
MsgBox "Eşit Olmayanları Aktardım", vbInformation, "Bitiş"
End Sub
ben bilmiyorum derseniz eğer eki inceleyin
Sayfa1'de eşitsiz diye bir buton mevcut ona tıklayın ve deneyin.
 

Ekli dosyalar

Merhaba,
Çabanız için teşekkür ederim.
Ancak bu çok karmaşık bir yapı...
Ben daha basite indirgeyip şöyle birşey istesem. Yardımcı olur musunuz?
B3 ve F3 deki eşitsizliği aradan kaldırsam (bunu ekranda filtre uygulayarak çözeceğim) ve sadece şöyle birşey istesem;

1 sayfanın B sutununda "ABC" geçiyor ise ikinci sayfa (ABC) ye, 1 sayfanın B sutununda "DEF" geçiyorsa DEF sayfasına C, D, E....sutun bilgileriyle birlikte atsın.
Yani ilk istediğim kurguda B3 ile F3 eşit değilse özelliğini kaldırarak ilk sayfadaki kaynağı değerleyerek ilgili sheetlere atmak istiyorum.
Yardımlarınızı rica ediyorum.
İlginize teşekkürler.
 
çok karmaşık anlatmışsınız.

B sütununda yazan'a göre mi sayfalara dağıtım yapılacak doğru mu anlamışım
 
Hocam karmaşıklık konusunda kusura bakmayın.
Sizin gönderdiğiniz en son formül yapısından B3 ile F3 eşit değilse özelliği olmadan basit bir kurgu istiyorum.
Eğer anlaşılmayan bir durum var ise baştan örneklerle tekrar anlatayım.
 
essenkaya' Alıntı:
Hocam karmaşıklık konusunda kusura bakmayın.
Sizin gönderdiğiniz en son formül yapısından B3 ile F3 eşit değilse özelliği olmadan basit bir kurgu istiyorum.
Eğer anlaşılmayan bir durum var ise baştan örneklerle tekrar anlatayım.
Genişletmek için tıkla ...

merhaba
üstte verdiğim kod'u bununla değiştirin
Kod: 
Option Explicit
Sub eşitsiz_aktar()
Dim ts, kaplan, abc, def, ghi, klm
kaplan = MsgBox("Sayfalara Aktarayım Mı_?", vbYesNo, "Onay")
If kaplan = vbNo Then Exit Sub
Sheets("abc").Range("B3:F65536").ClearContents
Sheets("def").Range("B3:F65536").ClearContents
Sheets("ghi").Range("B3:F65536").ClearContents
Sheets("klm").Range("B3:F65536").ClearContents
abc = 3: def = 3: ghi = 3: klm = 3
For ts = 3 To Sheets("Sayfa1").Cells(65536, "B").End(xlUp).Row
If Sheets("Sayfa1").Cells(ts, "B") = "abc" Then
Sheets("abc").Cells(abc, "B") = Sheets("Sayfa1").Cells(ts, "B")
Sheets("abc").Cells(abc, "C") = Sheets("Sayfa1").Cells(ts, "C")
Sheets("abc").Cells(abc, "D") = Sheets("Sayfa1").Cells(ts, "D")
Sheets("abc").Cells(abc, "E") = Sheets("Sayfa1").Cells(ts, "E")
Sheets("abc").Cells(abc, "F") = Sheets("Sayfa1").Cells(ts, "F")
abc = abc + 1
ElseIf Sheets("Sayfa1").Cells(ts, "B") = "def" Then
Sheets("def").Cells(def, "B") = Sheets("Sayfa1").Cells(ts, "B")
Sheets("def").Cells(def, "C") = Sheets("Sayfa1").Cells(ts, "C")
Sheets("def").Cells(def, "D") = Sheets("Sayfa1").Cells(ts, "D")
Sheets("def").Cells(def, "E") = Sheets("Sayfa1").Cells(ts, "E")
Sheets("def").Cells(def, "F") = Sheets("Sayfa1").Cells(ts, "F")
def = def + 1
ElseIf Sheets("Sayfa1").Cells(ts, "B") = "ghi" Then
Sheets("ghi").Cells(ghi, "B") = Sheets("Sayfa1").Cells(ts, "B")
Sheets("ghi").Cells(ghi, "C") = Sheets("Sayfa1").Cells(ts, "C")
Sheets("ghi").Cells(ghi, "D") = Sheets("Sayfa1").Cells(ts, "D")
Sheets("ghi").Cells(ghi, "E") = Sheets("Sayfa1").Cells(ts, "E")
Sheets("ghi").Cells(ghi, "F") = Sheets("Sayfa1").Cells(ts, "F")
ghi = ghi + 1
ElseIf Sheets("Sayfa1").Cells(ts, "B") = "klm" Then
Sheets("klm").Cells(klm, "B") = Sheets("Sayfa1").Cells(ts, "B")
Sheets("klm").Cells(klm, "C") = Sheets("Sayfa1").Cells(ts, "C")
Sheets("klm").Cells(klm, "D") = Sheets("Sayfa1").Cells(ts, "D")
Sheets("klm").Cells(klm, "E") = Sheets("Sayfa1").Cells(ts, "E")
Sheets("klm").Cells(klm, "F") = Sheets("Sayfa1").Cells(ts, "F")
klm = klm + 1
End If
Next
MsgBox "Sayfalara Aktardım", vbInformation, "Bitiş"
End Sub
ve deneyin.
veya eki inceleyin
 

Ekli dosyalar

Hocam,
ilgive alakanız için teşekkürler.
Ancak ben bunu başaramadım.
Yeni bir konu başlığı açarak yardım isteyeceğim.
Gerçekten çok teşekkür ederim Yeni bir örnek dosya yaptım.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst