Gruplama, Listeleme ..

[dEmir1]

Hayırlı Günler.
Açıklama örnek dosyada mevcuttur.
Teşekkür ederim.

 

[Emir Hüseyin Çoban]

. . .

Bunu yapabilmek için bir kaç püf noktayı teyit etmemiz gerekiyor.

Veri özelliklerine;
Bütün ürün isimleri harflerle mi başlıyor ?
Kodların hepsi sayısal değer mi ?

Hücre biçimlerine göre;
Kodların hücre biçimlendirmesi sabit mi ? (Dolgu var mı ?)
Ürün isimlerinde dolgu var mı ?

Bunlara göre
İlgili ürün ismini bul geriye doğru ilk sayısal değeri veya boyalı değeri getir gibi bir mantık kurulabilir.

. . .

 

[dEmir1]

Hüseyin bey merhaba
Evet ürün isimleri harflerle başlamaktadır.
Kodların hepsi sayısal değerlerden oluşmaktadır.
Sizin de dediğiniz gibi; İlgili ürün ismini bul geriye doğru ilk sayısal değeri getir gibi bir mantık kurulabilir.
&
Boyalı kısmı manuel yapılmıştır anlaşıla bilirlik adına yapmıştım fakat dediğiniz gibi Kod kısmı boyalı yapabilirim eğer ilgili ürünü bulup geriye doğru boyalı değeri getir gibi bir formül yapabilirseniz memnun olurum.
Aslında algoritmayı nasıl sağlarım bilemedim. Lakin siz çok güzel özetlemişsiniz.

 

[Emir Hüseyin Çoban]

. . .

B1 hücresine aranan ürün ismini girin.

Sub kod()
    Application.ScreenUpdating = False
    Dim sat As Integer
    Dim c, Adr
    
    sat = 2
    Range("G:H").ClearContents

    Set c = Range("A:A").Find(Range("B1"), , xlValues, xlWhole)
    If Not c Is Nothing Then
        Adr = c.Address
        Do
            If Range(Adr) = Range("b1") Then
                For i = c.Row To 1 Step -1
                    
                    If IsNumeric(Cells(i, "A")) Then
                        Cells(sat, "G") = Range(Adr)
                        Cells(sat, "H") = Cells(i, "A")
                        Exit For
                    Else
                    End If
                Next i

                sat = sat + 1
            End If
            Set c = Range("A:A").FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
        Application.ScreenUpdating = True
        MsgBox " B i t t i "
End Sub

. . .

 

[Murat OSMA]

Hüseyin Bey'in müsadesiyle.

Alternatif;

[FONT="Trebuchet MS"]Sub Emre()
    Dim i%, a%
    Range("G:H").ClearContents
    For i = 1 To Range("A65536").End(3).Row
        If Cells(i, 1) = Range("B1").Value Then
            Range("G65536").End(3)(2, 1) = Cells(i, 1)
        If Cells(i, 1).Interior.ColorIndex <> 44 Then
            For a = Cells(i, 1).Row To 1 Step -1
               If Cells(a, 1).Interior.ColorIndex = 44 Then
                    Range("H65536").End(3)(2, 1) = Cells(a, 1)
                    Exit For
                End If
            Next a
            End If
        End If
    Next i
    a = Empty: i = Empty
End Sub[/FONT]

 

[dEmir1]

Hüseyin bey elinize sağlık.
Murat bey sizlere de teşekkürler.
Bu kod olayı bambaşka bir şey
( Formül ile yapılabilir mi )

 

[Murat OSMA]

Rica ederiz.

Formülle bu şekilde yapabilirsiniz;

F2 hücresine bu formülü girin;

[FONT="Trebuchet MS"]=EĞERHATA(SATIR(İNDİS($A$1:$A$21;KÜÇÜK(EĞER($A$1:$A$21=$B$1;SATIR($A$1:$A$21));SATIR()-1)));"")[/FONT]

sonra Dizi formülüne dönüştürüp aşağıya doğru çekin..

G2 hücresine de bu formülü girin;

[FONT="Trebuchet MS"]=EĞERHATA(İNDİS($A$1:$A$21;KÜÇÜK(EĞER($A$1:$A$21=$B$1;SATIR($A$1:$A$21));SATIR()-1));"")[/FONT]

sonra Dizi formülüne dönüştürüp aşağıya doğru çekin..


H2 hücresine de bu formülü girip aşağıya doğru çekin;

[FONT="Trebuchet MS"]=EĞERHATA(ARA(F2;{1;7;14;21};{2028;282828;2727});"")[/FONT]