Başka Sayfadan Koşullu ve Kısmi Veri Çekme

[baydeniro]

Merhaba Arkadaşlar,

YEŞİL renkli D8 hücresinde belirtilen ÜRÜN türünü DATA sayfasında bulup bu ürün türündeki meyvelerin bulunduğu satıların DATA sayfası A-B-C sütunlarındaki verileri LISTA sayfasına B10 dan başlayarak listelenmesi mümkün müdür !

Örnek dosya linki : http://s7.dosya.tc/server12/xtg11k/KOSULLU_VERI_CEKME.xls.html

 

[Ziynettin]

Merhaba,

Deneyiniz....

Sub urun_Listele()
    Dim s1 As Worksheet, s2 As Worksheet, a(), b()
    Dim i As Long, say As Long
        Set s1 = Sheets("LISTE")
        Set s2 = Sheets("DATA")
        aranan = s1.[D8]
        a = s2.Range("A2:D" & s2.Cells(Rows.Count, 1).End(3).Row).Value
        ReDim b(1 To UBound(a), 1 To 4)
            For i = 1 To UBound(a)
                If a(i, 2) = aranan Then
                    say = say + 1
                    b(say, 1) = say
                    b(say, 2) = a(i, 1)
                    b(say, 3) = a(i, 2)
                    b(say, 4) = a(i, 3)
                End If
            Next i
        s1.Range("A10:D" & Rows.Count).ClearContents
    If say > 0 Then
        s1.[A10].Resize(say, 4) = b
    End If
    MsgBox "İşlem tamam.", vbInformation
End Sub

 

[baydeniro]

Ziynettin üstadım çok teşekkür ederim, harika bir kod olmuş, tam istediğim gibi. Elinize sağlık, sağlıcakla kalın.

 

[soneravci]

aradan epey bir zaman geçmiş ama biraz yeşertelim.

ziynettin beye çok teşekkür ederim zira çok basit ve işlevsel yazılı, fakat ben kendi dosyama uygulamaya kalktığımda (ki dosya yaklaşık 1,5 mb text ten oluşuyor.) maalesef sonuç alamadım.
şöyle ki;

Sub urun_Listele()
Dim s1 As Worksheet, s2 As Worksheet, a(), b()
Dim i As Long, say As Long
Set s1 = Sheets("LISTE") ------> sayfa adını aynı bıraktım çünkü benimki de aynı adda
Set s2 = Sheets("Talep") ------>arama yapılacak sayfaa adı talep olduğu için değiştirdim
aranan = s1.[A1] ------> aranan kelime veya ismin burda yazması gerekiyor (ki o da s1 ile tanımlı liste sayfasında olmalı)
a = s2.Range("A2:K" & s2.Cells(Rows.Count, 1).End(3).Row).Value ------>arama yapılacak aralık A2 den K sütununa kadar olacak çünkü aranan kelime k sütünunda yer alıyor


ReDim b(1 To UBound(a), 1 To 4)
For i = 1 To UBound(a)
If a(i, 2) = aranan Then
say = say + 1
b(say, 1) = say
b(say, 2) = a(i, 1)
b(say, 3) = a(i, 2)
b(say, 4) = a(i, 3)
End If ------>bunları olduğu gibi bıraktım çünkü sadece satırlara ardışık numara ekliyor
Next i
s1.Range("A10:K" & Rows.Count).ClearContents ------>yine bunu da listelemeye a 10 dan başlasın diye dokunmadım
If say > 0 Then
s1.[A10].Resize(say, 4) = b
End If
MsgBox "İşlem tamam.", vbInformation
End Sub

işlem bitiminde "İşlem tamam." mesajı alıyorum fakat liste sayfam hala boş kalıyor. sizden ricam bu durumu açıklığa kavuşturabilirseniz herkes bu yararlı makroyu kendi sayfasına uydurabilir.
iyi çalışmalar dilerim.

 

[canburak]

Merhaba,

Deneyiniz....

Sub urun_Listele()
    Dim s1 As Worksheet, s2 As Worksheet, a(), b()
    Dim i As Long, say As Long
        Set s1 = Sheets("LISTE")
        Set s2 = Sheets("DATA")
        aranan = s1.[D8]
        a = s2.Range("A2:D" & s2.Cells(Rows.Count, 1).End(3).Row).Value
        ReDim b(1 To UBound(a), 1 To 4)
            For i = 1 To UBound(a)
                If a(i, 2) = aranan Then
                    say = say + 1
                    b(say, 1) = say
                    b(say, 2) = a(i, 1)
                    b(say, 3) = a(i, 2)
                    b(say, 4) = a(i, 3)
                End If
            Next i
        s1.Range("A10:D" & Rows.Count).ClearContents
    If say > 0 Then
        s1.[A10].Resize(say, 4) = b
    End If
    MsgBox "İşlem tamam.", vbInformation
End Sub

Merhabalar hocam , yukaridaki makroda, "aranan D8" hucresine yerine bir sutun olarak nasil ayarlaya biliriz ?
yani su sekilde aciklarsak D2,D3,D4,D5.....Dx 'e yani D'sutununa ait son dolu hucreye kadar Data sayfasinda ayni olan verileri getirme olarak

 

[canburak]

Merhaba,

Deneyiniz....

Sub urun_Listele()
    Dim s1 As Worksheet, s2 As Worksheet, a(), b()
    Dim i As Long, say As Long
        Set s1 = Sheets("LISTE")
        Set s2 = Sheets("DATA")
        aranan = s1.[D8]
        a = s2.Range("A2:D" & s2.Cells(Rows.Count, 1).End(3).Row).Value
        ReDim b(1 To UBound(a), 1 To 4)
            For i = 1 To UBound(a)
                If a(i, 2) = aranan Then
                    say = say + 1
                    b(say, 1) = say
                    b(say, 2) = a(i, 1)
                    b(say, 3) = a(i, 2)
                    b(say, 4) = a(i, 3)
                End If
            Next i
        s1.Range("A10:D" & Rows.Count).ClearContents
    If say > 0 Then
        s1.[A10].Resize(say, 4) = b
    End If
    MsgBox "İşlem tamam.", vbInformation
End Sub

Tekrar merhaba yukaridaki formulleri uyarladim, 32 ci satira kada duzgun calisiyor ondan sonrasininda verileri hatali getiriyor isin icinden cikamadim! ornek dosya ektedir.
yardimlariniz icin simdiden tesekkurler.
Saygilarimla,

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Listele()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Veri As Variant, X As Long, Son As Long
    Dim Dizi As Object, Aranan As Range, Say As Long
   
    Set S1 = Sheets("data")
    Set S2 = Sheets("raport")
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")
   
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
   
    Veri = S1.Range("A2:I" & Son).Value
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 9) = "Kapali" Then
            If Not Dizi.Exists(Veri(X, 7)) Then
                Dizi.Add Veri(X, 7), Veri(X, 3)
            End If
        End If
    Next

    Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
   
    Veri = S2.Range("A2:A" & Son).Value
   
    ReDim Liste(1 To Son - 1, 1 To 2)
       
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Say = Say + 1
        If Dizi.Exists(Veri(X, 1)) Then
            Liste(Say, 1) = Veri(X, 1)
            Liste(Say, 2) = Dizi.Item(Veri(X, 1))
        End If
    Next
   
    S2.Range("B2:C" & S2.Rows.Count).ClearContents
   
    If Say > 0 Then S2.Range("B2").Resize(Say, 2) = Liste

    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[canburak]

Deneyiniz.

Option Explicit

Sub Listele()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Veri As Variant, X As Long, Son As Long
    Dim Dizi As Object, Aranan As Range, Say As Long
 
    Set S1 = Sheets("data")
    Set S2 = Sheets("raport")
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")
 
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
 
    Veri = S1.Range("A2:I" & Son).Value
 
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 9) = "Kapali" Then
            If Not Dizi.Exists(Veri(X, 7)) Then
                Dizi.Add Veri(X, 7), Veri(X, 3)
            End If
        End If
    Next

    Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
 
    Veri = S2.Range("A2:A" & Son).Value
 
    ReDim Liste(1 To Son - 1, 1 To 2)
     
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Say = Say + 1
        If Dizi.Exists(Veri(X, 1)) Then
            Liste(Say, 1) = Veri(X, 1)
            Liste(Say, 2) = Dizi.Item(Veri(X, 1))
        End If
    Next
 
    S2.Range("B2:C" & S2.Rows.Count).ClearContents
 
    If Say > 0 Then S2.Range("B2").Resize(Say, 2) = Liste

    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Koray Hocam , Cok tesekkur ediyorum Elinize saglik calisiyor.

Saygilarimla,

 

[canburak]

Deneyiniz.

Option Explicit

Sub Listele()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Veri As Variant, X As Long, Son As Long
    Dim Dizi As Object, Aranan As Range, Say As Long
 
    Set S1 = Sheets("data")
    Set S2 = Sheets("raport")
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")
 
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
 
    Veri = S1.Range("A2:I" & Son).Value
 
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 9) = "Kapali" Then
            If Not Dizi.Exists(Veri(X, 7)) Then
                Dizi.Add Veri(X, 7), Veri(X, 3)
            End If
        End If
    Next

    Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
 
    Veri = S2.Range("A2:A" & Son).Value
 
    ReDim Liste(1 To Son - 1, 1 To 2)
     
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Dizi.Exists(Veri(X, 1)) Then
            Say = Say + 1
            Liste(Say, 1) = Veri(X, 1)
            Liste(Say, 2) = Dizi.Item(Veri(X, 1))
        End If
    Next
 
    S2.Range("B2:C" & S2.Rows.Count).ClearContents
 
    If Say > 0 Then S2.Range("B2").Resize(Say, 2) = Liste

    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Hocam formulleri okumaya calisiyorum ama tam okuyamadim burda -1,1 to 2 tam ne anlama geliyor ve buna ek olarak benim Data sayfamda ilaveten D sutunundaki veriyide raport sayfasinda E sutununa almam gerekiyor Asil tablomda onu nasil ekleye bilirim?

ReDim Liste(1 To Son - 1, 1 To 2)

For X = LBound(Veri, 1) To UBound(Veri, 1)
Say = Say + 1
If Dizi.Exists(Veri(X, 1)) Then
Liste(Say, 1) = Veri(X, 1)
Liste(Say, 2) = Dizi.Item(Veri(X, 1))
End If
Next

 

[canburak]

Hocam daha anlasilir olmasi bakimindan soyle izah edeyim; Liste(Say, 3) = Dizi.Item(Veri(X, *)) sekilde ilave bir veri daha eklemem lazim ve verinin bulundugu yerde DATA sayfasindaki D sutunundan almasi gerekiyor.

Saygilarimla,

 

[Korhan Ayhan]

Bu durumu neden baştan izah etmediniz peki..

 

[canburak]

Bu durumu neden baştan izah etmediniz peki..

Hocam dusundum sizin formullerinize bakarak uyarlaya bilirim, ama diger sutunlara uyarlayamadim,

 

[Korhan Ayhan]

Bu kodlar bir tık ileri seviye kodlardır.

Bu tarz kodları revize edebilmeniz için temel VBA bilgisine sahip olmanız gerekir.

 

[canburak]

Maalesef hocam okadar bilgide bizde yok , Anladigim kadari ile 3 cu veri getirmek icin makro komple degismesi gerekiyor!
Tesekkurler,

 

[Korhan Ayhan]

Cevap veren bizlerde zamanımızı daha verimli kullanmaya çalışıyoruz. Ama düşünün günde 10 kişi bu şekilde yardım talebinde bulunursa bizler cevap verdikten sonra tekrar tekrar aynı konuya dönüp zaman kaybetmek pek hoş olmuyor. Öğrenmek istiyorsanız kursa gidebilirsiniz.

 

[canburak]

Haklisiz hocam, bu kadar komplike olacagini dusunmemistim, birdahaki sefer full listeyi gecerim, yurtdisinda kursa gitmek zor o kadar yeterli ingilizceye sahip degilim gerci islerden de pek vakit bulamiyoruz,

 

[canburak]

Hocam aslinda suan kullandigim orjinal makro assagidaki gibi idi ama sistemi cok kasiyordu ,hareket cok oldugu icin, bunu uyarlamaya calismistim , size gonderdigim ornek dosyada ,

Set Veri = Sheets("Cost")
Set getir = Sheets("Cost")

sonA = Veri.Cells(Rows.Count, "AP").End(3).Row
SonB = getir.Cells(Rows.Count, "AP").End(3).Row

For satir = 3 To SonB

getir.Cells(satir, "BA") = WorksheetFunction.SumIfs(Veri.Range("AB3:AB" & sonA), Veri.Range("AF3:AF" & sonA), _
getir.Cells(satir, "AW"), Veri.Range("AP3:AP" & sonA), "<>760", Veri.Range("AB3:AB" & sonA), ">0")

getir.Cells(satir, "BB") = WorksheetFunction.SumIfs(Veri.Range("AC3:AC" & sonA), Veri.Range("AF3:AF" & sonA), _
getir.Cells(satir, "AW"), Veri.Range("AP3:AP" & sonA), "<>760", Veri.Range("AC3:AC" & sonA), ">0")

getir.Cells(satir, "BC") = WorksheetFunction.SumIfs(Veri.Range("AC3:AC" & sonA), Veri.Range("AF3:AF" & sonA), _
getir.Cells(satir, "AW"), Veri.Range("AP3:AP" & sonA), "<>760", Veri.Range("AC3:AC" & sonA), ">0")

Next

End Sub

 

[Korhan Ayhan]

Bu kodlar klasik fonksiyonun makro karşılığıdır. Makro ile uygulandığı için dosyada bir tık rahatlama sağlar. Fakat hız için ado, dictionary, dizi yöntemi gibi teknikleri kullanmanız gerekir. Bu tarz kodlar ileri seviye dediğimiz kodlardır. Fakat öğrenmesi zor değildir. Biraz zaman ayırıp gayret göstermek gerekiyor.

 

[canburak]

Sagolun hocam su an icin usteki gonderdiginiz vba 3 sutuna acil ihtiyacim vardi mumkunse yapabilirmisiniz , sonra dedillerinizi arastiracagim
Saygilarimla,

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Listele()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Veri As Variant, X As Long, Son As Long
    Dim Dizi As Object, Aranan As Range, Say As Long
  
    Set S1 = Sheets("data")
    Set S2 = Sheets("raport")
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")
  
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
  
    Veri = S1.Range("A2:I" & Son).Value
  
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 9) = "Kapali" Then
            If Not Dizi.Exists(Veri(X, 7)) Then
                Dizi.Add Veri(X, 7), Array(Veri(X, 3), Veri(X, 4))
            End If
        End If
    Next

    Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
  
    Veri = S2.Range("A2:A" & Son).Value
  
    ReDim Liste(1 To Son - 1, 1 To 3)
      
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Say = Say + 1
        If Dizi.Exists(Veri(X, 1)) Then
            Liste(Say, 1) = Veri(X, 1)
            Liste(Say, 2) = Dizi.Item(Veri(X, 1))(0)
            Liste(Say, 3) = Dizi.Item(Veri(X, 1))(1)
        End If
    Next
  
    S2.Range("B2:D" & S2.Rows.Count).ClearContents
  
    If Say > 0 Then S2.Range("B2").Resize(Say, 3) = Liste

    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
  
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub