aynı değerleri bulmak

[ibrahimelmali]

selam arkadaşlar elimde aşağıdaki gibi bir tablom var ben bunları filtrelemek istiyorum aşağıdaki verdiğim örnek içerik aynı fiyat farklı bunun gibi bir çok satır var ben istiyorum ki uçuran 2 gb yazan ürünün liste içerisinde bir çok farklı fiyatlarda alternatifi var içeriğine uygun ve fiyatı ondan daha aşağı olan ürünleri listelemek ve aynı zaman da da içeriği ondan yüksek ama fiyatı uçuran 2 gb yazan satırdan daha aşağı olan ürünler var bu şekilde bir filtremeyi nasıl yapabiliriz



paket ismi dk sms internet fiyat
süper avantaj 500 1000 2 gb 19
uçuran 2 gb 500 1000 2 gb 36

 

[Ömer]

Merhaba,

Verdiğiniz örnekteki düzenine göre:
Sayfa1 A:E arasındaki paket verilerini özetleyerek Sayfa2 de listeler.

Verdiğiniz örneğe göre Sayfa2 de sonuç:
A2: 500|1000|2 gb
B2: süper avantajPaket > 19 TL
C2: uçuran 2 gbPaket > 36 TL

şeklinde aynı paket içeriğini tek hücrede yazıp yan sütunlara paket bilgisini ve fiyatını yazar.

Sub Ozet_Al()

    Dim d As Object, i As Long, s, deg1, deg2

    Set d = CreateObject("Scripting.Dictionary")
    
    Application.ScreenUpdating = False
    Sheets("Sayfa1").Select

    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        deg1 = Cells(i, "B") & "|" & Cells(i, "C") & "|" & Cells(i, "D")
        deg2 = Cells(i, "A") & "Paket > " & Cells(i, "E") & " TL"
        If Not d.exists(deg1) Then
            s = deg2
            d.Add deg1, s
        Else
            s = d.Item(deg1)
            s = s & "|" & deg2
            d.Item(deg1) = s
        End If
    Next i

    Sheets("Sayfa2").Select
    Cells.ClearContents
    Range("A2").Resize(d.Count, 2) = _
        Application.Transpose(Array(d.keys, d.items))
    
    Range("A1") = "Paket: dk|sms|internet": Range("B1") = "Paket-Fiyat >"
    Application.DisplayAlerts = False
    Range("B2:B" & d.Count + 1).TextToColumns Destination:=Range("B2"), _
        DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
            Other:=True, OtherChar:="|", TrailingMinusNumbers:=True
        
    Cells.EntireColumn.AutoFit
        
    Application.ScreenUpdating = True

End Sub

.

 

[ibrahimelmali]

tşk ederim verdiğiniz bilgi için ama ben kodları ya ekleyemedim yada ben yapamadı rica etsem excell dosyasına ekleyip mail olarak atmanız mümkün mü

ibrahimelmali@hotmail.com

 

[Ömer]

Linkten dosyayı indirebilirsiniz.

http://s3.dosya.tc/server14/4wiuz4/ozet_al.rar.html

.

 

[ibrahimelmali]

tşk ederim elinize sağlık