Verileri guruplama hususunda makro.

[desıgner1]

Merhabalar, ekli dosyada verilerin belirli kritere göre guruplandırılması ve
ilgili gurubun numaralandırılması ile ilgili bir makro ya ihtiyacım var.
Değerli bilgilerinizi paylaşırsanız sevinirim.

 

[antonio]

Sub gruplandir()
Dim sh As Worksheet, ss As Long, i As Long, puan As Integer, eski As Range, yeni As Range
puan = 0
Set sh = Sheets(1)
ss = sh.Range("E" & Rows.Count).End(3).Row
For i = 7 To ss
    Set eski = sh.Range("E" & i - 1)
    Set yeni = sh.Range("E" & i)
    If eski.Value <> yeni.Value Then
        puan = puan + 1
    End If
    sh.Range("H" & i).Value = puan
Next i
End Sub

 

[Asri]

Aşağıdaki formül boş satır açmaz, ancak gruplama yapar.
Formülü G7 yapıştırıp aşağı doğru çekin.

=EĞER(YADA(E6<>E7;F6<>F7);G6+1;G6)

 

[desıgner1]

İlginiz için teşekkür ederim,

Sayın antonio makro yanlış sonuç üretiyor.
Aynı zamanda boşlukların da açılması lazım.

Sayın asri, işlemin makro ile yapılması lazım.

 

[desıgner1]

Merhabalar;
Tüm forum ahalisinin bayramı kutlu olsun.

Konu anlaşılmamış sanırım.
Döngü oluşturuyoruz.

E sütunu daki veri bir sonraki veri ile aynı ise,
ve bu verilerin karışlığında F sütunundaki verilerde birbirleri ile aynı ise
bu bir gurup olmuş oluyor. ve Bu guruba benzersiz bir numara veriyoruz.

Değerli yardımlarınızı bekliyorum. Örnek dosyada şekil olarak çıkması gereken sonucu
belirttim.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub GRUPLANDIR()
    Dim Sayı As Long, Son As Long, X As Long, Y As Long
    Range("H7:H" & Rows.Count).ClearContents
    Range("E7:E" & Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Sayı = 1
    Son = Cells(Rows.Count, "E").End(3).Row
    For X = 7 To Son
        Cells(X, "H") = Sayı
        For Y = X + 1 To Son + 1
            If Cells(X, "E") & Cells(X, "F") = Cells(Y, "E") & Cells(Y, "F") Then
                Cells(Y, "H") = Sayı
            Else
                X = Y - 1
                Sayı = Sayı + 1
                Exit For
            End If
        Next
    Next
    
    For X = Son To 8 Step -1
        If Cells(X, "H") <> Cells(X - 1, "H") Then
            Rows(X).Insert
        End If
    Next
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub