Soru Veriyi taratıp belli koşullara uyanları bulma

[ilgisizlik]

Sevgili hocalarım merhabalar,

Benim için çok önemli olan aşağıdaki konu için değerli yardımlarınızı rica ediyorum.

Örnek excel dosyası : https://s4.dosya.tc/server14/suh1s2/sayihesaplama.xlsx.html

Örnek excel dosyasında toplamda 4 sütun kullanmam gerekiyor.

A sütunu - sayılar : Bu sütunda verilerimin tamamı olacak. Yüz bin satırı da bulabilir burası, sonu yok. Bu sütunda sadece sayılarım olacak, veri kaynağım bu sütun.

F sütunu - Son 2 : Bu sütunda ise A sütunundaki son yazılmış 2 sayıyı tüm veri kaynağında arayarak bulup, kaç tane varsa o 2 sayının bir altındaki rakamı yazmasını bekliyorum.
Mesela örnek excelde son 2 sayı 12 ve 34, tüm veriye baktığımızda 12 ve 34 sayısı 2 kere tekrar etmiş ve bu sayılardan sonra gelen ilk sayı 7, ikinci sayı ise 15 görünüyor, bunlar da F sütununda yazılmış şekilde.

G ve H sütunundaki Son 3 ve Son 4 sütunları ise en son yazılmış 3 sayı ve 4 sayı için çalışması gerekiyor.

Son olarak Son 2, Son 3 ve Son 4 başlıklı alanlarda aynı sayıların olması durumunda mümkünse sadece o sayıları renklendirmesi çok iyi olur.

Yardımlarınız için şimdiden çok teşekkür ediyorum.

 

[ilgisizlik]

Acaba imkansız bir şey mi istedim bilmiyorum ama benim için gerçekten çok önemli, lütfen yardım ederseniz size minnettar olurum, renk olayı olmasa da olur...

 

[ÖmerFaruk]

Aşağıdaki kodları bir modül içine ekleyip sayfa üzerinde çalıştırabilirsiniz.

Sub Sayılar()
Dim Veri, MyRange As Range, hcr As Range, Say As Long, i As Long
    Veri = Range("A2:A" & Range("A" & Rows.Count).End(3).Row).Value
    LastValues = Range("A" & Rows.Count).End(3).Offset(-3, 0).Resize(4, 1).Value
    Range("F2:H" & Rows.Count).Clear
    Set MyRange = Range("F2:H2")
    
    ReDim Liste(1 To UBound(Veri), 1 To 1)
    Say = 0
    For i = 1 To UBound(Veri) - 3
        If Veri(i, 1) = LastValues(3, 1) And Veri(i + 1, 1) = LastValues(4, 1) Then
            Say = Say + 1
            Liste(Say, 1) = Veri(i + 2, 1)
            i = i + 2
        End If
    Next
    If Say > 0 Then
        Range("F2").Resize(Say, 1) = Liste
        If MyRange.Rows.Count < Say Then Set MyRange = Range("F2:H" & Say + 1)
    End If
    ReDim Liste(1 To UBound(Veri), 1 To 1)
    Say = 0
    For i = 1 To UBound(Veri) - 3
        If Veri(i, 1) = LastValues(2, 1) And Veri(i + 1, 1) = LastValues(3, 1) And Veri(i + 2, 1) = LastValues(4, 1) Then
            Say = Say + 1
            Liste(Say, 1) = Veri(i + 3, 1)
            i = i + 3
        End If
    Next
    If Say > 0 Then
        Range("G2").Resize(Say, 1) = Liste
        If MyRange.Rows.Count < Say Then Set MyRange = Range("F2:H" & Say + 1)
    End If
    ReDim Liste(1 To UBound(Veri), 1 To 1)
    Say = 0
    For i = 1 To UBound(Veri) - 4
        If Veri(i, 1) = LastValues(1, 1) And Veri(i + 1, 1) = LastValues(2, 1) And Veri(i + 2, 1) = LastValues(3, 1) And Veri(i + 3, 1) = LastValues(4, 1) Then
            Say = Say + 1
            Liste(Say, 1) = Veri(i + 4, 1)
            i = i + 3
        End If
    Next
    If Say > 0 Then
        Range("H2").Resize(Say, 1) = Liste
        If MyRange.Rows.Count < Say Then Set MyRange = Range("F2:H" & Say + 1)
    End If
    For Each hcr In MyRange
        If WorksheetFunction.CountIf(MyRange, hcr) > 1 Then hcr.Interior.Color = vbYellow
    Next hcr
    MyRange.HorizontalAlignment = xlHAlignCenter
    Set MyRange = Nothing
    Erase Veri: Erase LastValues: Erase Liste
End Sub

 

[ilgisizlik]

Hocam öncelikle zahmet edip yazdığınız için çok teşekkür ediyorum. Kodları modül içerisine yerleştirmeyi araştırıp hemen deneyeceğim.

 

[ÖmerFaruk]

Sadece mevcut excel dosyanız kalsın.
Sayfa açıkken Alt+F11
Çıkan VBA penceresinde sol üstte kitap ve sayfa isminizi göreceksiniz.
Sağ tık / Insert Module
Buraya yapıştırın.

Bitmiş halini link olarak paylaşıyorum ama siz yine de aynısını yapmaya gayret edin.
Bu linkte dosyanız var. Harici linktir.