Düşeyara fonksiyonu ile aynı kişiye ait birden fazla kaydı listelemek

[rayko]

Tahsinanarat kardeşim çok güzel ellerine sağlık emeğine sağlık

 

[rayko]

Tahsinarat kardeşim;

Ben aynı işlevi ek'te ki dosya içinde yapmak istiyorum. Sayfa3 de firma numaralarının altına, sayfa2nin b sütunundaki numaralardan birini yazınca bilgiler çıkıyor.Ben önceki ekte olduğu gibi aynı olanların alt alta sıralanmasını ve kaldığım yerden kod girmeye devam etmesini istiyorum.Sabahdan beri önceki verdiğiniz kodlar üzerinde uğraştım beynim sulandı yapamadım sayenizde bunu da yaparsanız az çok mantığı kapmış olacam teşekkürler.

Dosya eki:

Ekli dosyayı görüntüle KİTAP.xls

..

 

[vardar07]

Arkadaşım Sayfa2 de B4,B5,B6 daki formuller içindeki D8 Değerini D100 yaparsan Sayfa1 de97 adet giriş yaparsın.

=DÜŞEYARA(Sayfa2!B3;Sayfa1!A1:D8;2;YANLIŞ)

 

[rayko]

vardar07 kardeşim o ekle sıkıntım yok yukarda yeni ek var KİTAP.xls onunla ilgili sıkıntım

 

[rayko]

Tahsinarat kardeşim;

Ben aynı işlevi ek'te ki dosya içinde yapmak istiyorum. Sayfa3 de firma numaralarının altına, sayfa2nin b sütunundaki numaralardan birini yazınca bilgiler çıkıyor.Ben önceki ekte olduğu gibi aynı olanların alt alta sıralanmasını ve kaldığım yerden kod girmeye devam etmesini istiyorum.Sabahdan beri önceki verdiğiniz kodlar üzerinde uğraştım beynim sulandı yapamadım sayenizde bunu da yaparsanız az çok mantığı kapmış olacam teşekkürler.

Dosya eki:

Ekli dosyayı görüntüle 136476

..

çözüm bula bilen var mı ?

 

[tahsinanarat]

Dosyanız ekte

Datalarınız çoğaldıkça hesaplama süresi de bi o kadar artacaktır.
formüllerde sayfa2 den gelecek data satır sayısını 1000 olarak ayarladım, Sayfa3 de ise 101 satıra kadar formüller kopyalıdır, siz gerektiği kadar çekerek çoğaltınız.

 

[rayko]

Teşekkürederim kardeşim sayenizde birşeyler öğreniyorum vba kodları için eğitim setinden de yardım alıyorum inş öğrenirsem bende sizin gibi diğer kardeşlerime yardımcı olacam sayeniz de

 

[bedburg]

selamunaleykum arkadaşlar..elimde iki tablo var .birisi stok diğeri üretim bekleyen ürünler..üretim bekleyen tabloda herhangibir ürün koduna ait ürünün stokta hangi ülkede ve ne kadar olduğuna bakacam fakat düşeyara sadece ilk gördüğü ülkenin adedini getiriyor ikinci veya üçüncü ülkelerde aynı ürün varsa onu görmüyor.bu konuda yardımcı olabilecek varmı?[URL=http://dosya.co/5c3fbisfh7dd/40.hafta_uretım_bekleyenler.v3.xlsx.html]40.hafta uretım bekleyenler.v3.xlsx - 468 KB[/URL]
[URL=http://dosya.co/q6idx49fptzf/STOK_30.09.xlsx.html]STOK 30.09.xlsx - 125 KB[/URL]

 

[dkandak]

Merhaba,
Öncelikle aranıza yeni katılmış olmanın mutluluğunu yaşıyorum.
Sorunum ise şu; örnek eklediğim excelde fidan kısmına; "ağaç" sayfasından verileri getirsin istiyorum. Ancak bu sayfada Ali Balcı ismi 3 defa yazmak zorunda, diğer sayfada Ali Balcı 2 yerde var, 2si yazsın 3.sü boş olsun. Diğer yandan Ali Demir bu sayfada 3 tane var diğer sayfada 5 tane var, 5 veri de buraya gelsin istiyorum.
Teşekkür ederim.

 

[dkandak]

Merhaba, cevap verecek kimse yok mu acaba?

 

[Korhan Ayhan]

Merhaba,

Sonuç olarak görmek istediğiniz tabloyu örnek dosyanıza ekleyip paylaşırsanız yanıt almanız daha da hızlanacaktır.

 

[dkandak]

Merhaba,

Sonuç olarak görmek istediğiniz tabloyu örnek dosyanıza ekleyip paylaşırsanız yanıt almanız daha da hızlanacaktır.

Merhaba,
Ekledim...

 

[Korhan Ayhan]

Paylaştığınız örnek dosyada ALİ DEMİR kişisi 6 satırda geçiyor. Siz 5 satırlık bilgiyi diğer sayfada göstermişsiniz.

Her kişi için maksimum 5 satır mı göstermek istiyorsunuz?

 

[dkandak]

Paylaştığınız örnek dosyada ALİ DEMİR kişisi 6 satırda geçiyor. Siz 5 satırlık bilgiyi diğer sayfada göstermişsiniz.

Her kişi için maksimum 5 satır mı göstermek istiyorsunuz?

Her kişi için maksimum 7 satır olmasını istiyorum.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Tablolari_Birlestir()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Veri As Variant, X As Long, Say As Long
    Dim Bul As Range, Adres As String
    Dim WF As WorksheetFunction, Sayac As Long
    Dim Say_1 As Long, Say_2 As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("veri")
    Set S2 = Sheets("ağaç")
    Set WF = WorksheetFunction
    
    Veri = S1.Range("A2:E" & S1.Cells(S1.Rows.Count, 1).End(3).Row).Value
    
    ReDim Liste(1 To S1.Rows.Count, 1 To 5)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            Say_1 = WF.CountIf(S1.Range("C:C"), Veri(X, 3))
            Say_2 = WF.CountIf(S2.Range("C:C"), Veri(X, 3))
            If Say_1 > 0 And Say_2 > 0 Then
                Set Bul = S2.Range("C:C").Find(Veri(X, 3), , , xlWhole)
                If Not Bul Is Nothing Then
                    Adres = Bul.Address
                    Do
                        If Bul.Offset(, 3) = "" Then
10                          Say = Say + 1
                            Sayac = Sayac + 1
                            Liste(Say, 1) = Veri(X, 1)
                            Liste(Say, 2) = Veri(X, 2)
                            Liste(Say, 3) = Veri(X, 3)
                            If Not Bul Is Nothing Then
                                Liste(Say, 4) = Bul.Offset(, 1)
                                Liste(Say, 5) = Bul.Offset(, 2)
                                Bul.Offset(, 3) = "X"
                            End If
                        End If
                        If Bul Is Nothing Then Exit Do
                        Set Bul = S2.Range("C:C").FindNext(Bul)
                    Loop While Not Bul Is Nothing And Bul.Address <> Adres
                    If Sayac < Say_1 And Say_2 < Say_1 Then
                        Set Bul = Nothing
                        GoTo 10
                    End If
                    Sayac = 0
                    X = X + Say_1 - 1
                End If
            Else
                Say = Say + 1
                Liste(Say, 1) = Veri(X, 1)
                Liste(Say, 2) = Veri(X, 2)
                Liste(Say, 3) = Veri(X, 3)
                Liste(Say, 4) = "YOK"
                Liste(Say, 5) = "YOK"
            End If
        End If
    Next

    S1.Range("A2:E" & S1.Rows.Count).ClearContents
    S1.Range("A2").Resize(Say, 5) = Liste
    S2.Range("F:F").ClearContents

    Set S1 = Nothing
    Set S2 = Nothing
    Set WF = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
End Sub

 

[dkandak]

Deneyiniz.

Option Explicit

Sub Tablolari_Birlestir()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Veri As Variant, X As Long, Say As Long
    Dim Bul As Range, Adres As String
    Dim WF As WorksheetFunction, Sayac As Long
    Dim Say_1 As Long, Say_2 As Long
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set S1 = Sheets("veri")
    Set S2 = Sheets("ağaç")
    Set WF = WorksheetFunction
   
    Veri = S1.Range("A2:E" & S1.Cells(S1.Rows.Count, 1).End(3).Row).Value
   
    ReDim Liste(1 To S1.Rows.Count, 1 To 5)
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            Say_1 = WF.CountIf(S1.Range("C:C"), Veri(X, 3))
            Say_2 = WF.CountIf(S2.Range("C:C"), Veri(X, 3))
            If Say_1 > 0 And Say_2 > 0 Then
                Set Bul = S2.Range("C:C").Find(Veri(X, 3), , , xlWhole)
                If Not Bul Is Nothing Then
                    Adres = Bul.Address
                    Do
                        If Bul.Offset(, 3) = "" Then
10                          Say = Say + 1
                            Sayac = Sayac + 1
                            Liste(Say, 1) = Veri(X, 1)
                            Liste(Say, 2) = Veri(X, 2)
                            Liste(Say, 3) = Veri(X, 3)
                            If Not Bul Is Nothing Then
                                Liste(Say, 4) = Bul.Offset(, 1)
                                Liste(Say, 5) = Bul.Offset(, 2)
                                Bul.Offset(, 3) = "X"
                            End If
                        End If
                        If Bul Is Nothing Then Exit Do
                        Set Bul = S2.Range("C:C").FindNext(Bul)
                    Loop While Not Bul Is Nothing And Bul.Address <> Adres
                    If Sayac < Say_1 And Say_2 < Say_1 Then
                        Set Bul = Nothing
                        GoTo 10
                    End If
                    Sayac = 0
                    X = X + Say_1 - 1
                End If
            Else
                Say = Say + 1
                Liste(Say, 1) = Veri(X, 1)
                Liste(Say, 2) = Veri(X, 2)
                Liste(Say, 3) = Veri(X, 3)
                Liste(Say, 4) = "YOK"
                Liste(Say, 5) = "YOK"
            End If
        End If
    Next

    S1.Range("A2:E" & S1.Rows.Count).ClearContents
    S1.Range("A2").Resize(Say, 5) = Liste
    S2.Range("F:F").ClearContents

    Set S1 = Nothing
    Set S2 = Nothing
    Set WF = Nothing
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
End Sub

Maksimum 5 satır olacak şekilde yapmışsınız sanırım.
Ellerinize sağlık çok teşekkür ederim.

 

[Korhan Ayhan]

Bir satır sınırlaması koymadım. "ağaç" isimli sayfanızda eğer en fazla 5 satırlık blok içeren veri varsa ona göre kod o sebeple 5 satırlık sonuç veriyordur.

Mesela denemek için ALİ DEMİR verisini "ağaç" sayfasında 10 satır çoğaltarak kodu çalıştırdığınızda 10 satırlık veriyi aldığını görebilirsiniz.

 

[polis-53]

Merhabalar birden çok veriyi ayni hücrede yazdırabilir miyiz.

 

[Korhan Ayhan]

Evet yazdırabilirsiniz..