Soru a sütununda tekrar eden sütunları b sütununa göre sıralama

[IRONSELF]

kolay gelsin öncelikle
ekte açıklamayı yaptım umarım anlatabildim . bu konuda yardımcı olur musunuz.

 

[Muzaffer Ali]

Merhaba.
Aşağıdaki kod ile yapabilirsiniz.

Sub Test()
    Dim Bak As Long
    Dim Say As Long
    Dim dizi
    Say = Cells(Rows.Count, "A").End(xlUp).Row
    For Bak = 2 To Say Step 3
        dizi = Range("D" & Bak & ":D" & Bak + 2)
        For a = LBound(dizi) To (UBound(dizi) - 1)
            For b = (a + 1) To UBound(dizi)
                If dizi(a, 1) > dizi(b, 1) Then
                    Txt = dizi(a, 1)
                    dizi(a, 1) = dizi(b, 1)
                    dizi(b, 1) = Txt
                    Txt = ""
                End If
            Next b
        Next a
        For i = Bak To Bak + 2
            d = d + 1
            Cells(i, "E") = dizi(d, 1)
        Next i
        d = 0
    Next
End Sub

 

[IRONSELF]

teşekkürler ama bazılarında olmadı. örneğin A221 A222 A223

 

[EmrExcel16]

Alternatif olarak birde böyle dener misiniz.

Sub Emr()
    Dim i
    Application.ScreenUpdating = False
    Range("E2:E" & Cells(Rows.Count, 1).End(3).Row).Value = Range("D2:D" & Cells(Rows.Count, 1).End(3).Row).Value
    For i = 2 To Cells(Rows.Count, 1).End(3).Row Step 3
        Range("E" & i & ":" & "E" & i + 2).Sort key1:=Range("E" & i), order1:=xlAscending, Header:=xlNo
    Next
    MsgBox "İslem tamam"
    Application.ScreenUpdating = True
End Sub

 

[IRONSELF]

malesef yine olmadı.

 

[Korhan Ayhan]

Sizin görek istediğiniz sonucuda örnek dosyanızda paylaşırsanız kafa karışıklığı ortadan kalkacaktır. Daha net cevap alabilirsiniz.

 

[EmrExcel16]

Korhan Hocam birde bu şekilde denesin arkadaş , demek istediğini tahminimce anladım .

Sub Emr()
    Dim i
    Application.ScreenUpdating = False
    Range("E2:E" & Cells(Rows.Count, 1).End(3).Row).Value = Range("D2:D" & Cells(Rows.Count, 1).End(3).Row).Value
    bas = 2
    On Error Resume Next
    
    For i = 2 To Cells(Rows.Count, 1).End(3).Row
        If Cells(i, 1) <> Cells(i - 1, 1) And i > 2 Then
            Range("E" & bas & ":" & "E" & i - 1).Sort key1:=Range("E" & bas), order1:=xlAscending, Header:=xlNo
            bas = Cells(i, 1).Row
        End If
    Next
    
    Range("E" & bas & ":" & "E" & i - 1).Sort key1:=Range("E" & bas), order1:=xlAscending, Header:=xlNo
    MsgBox "İslem tamam"
    Application.ScreenUpdating = True
End Sub

 

[IRONSELF]

Sizin görek istediğiniz sonucuda örnek dosyanızda paylaşırsanız kafa karışıklığı ortadan kalkacaktır. Daha net cevap alabilirsiniz.

kusura bakmayın sadece bazı satırlarda olunca örnek atmadım

 

[IRONSELF]

Korhan Hocam birde bu şekilde denesin arkadaş , demek istediğini tahminimce anladım .

Sub Emr()
    Dim i
    Application.ScreenUpdating = False
    Range("E2:E" & Cells(Rows.Count, 1).End(3).Row).Value = Range("D2:D" & Cells(Rows.Count, 1).End(3).Row).Value
    bas = 2
    On Error Resume Next
   
    For i = 2 To Cells(Rows.Count, 1).End(3).Row
        If Cells(i, 1) <> Cells(i - 1, 1) And i > 2 Then
            Range("E" & bas & ":" & "E" & i - 1).Sort key1:=Range("E" & bas), order1:=xlAscending, Header:=xlNo
            bas = Cells(i, 1).Row
        End If
    Next
   
    Range("E" & bas & ":" & "E" & i - 1).Sort key1:=Range("E" & bas), order1:=xlAscending, Header:=xlNo
    MsgBox "İslem tamam"
    Application.ScreenUpdating = True
End Sub

emeğinize sağlık bir önceki kodla eksik kalanları tespit edip küçük formülü ile çözdüm son kod kilitledi. çok saolun

 

[EmrExcel16]

emeğinize sağlık bir önceki kodla eksik kalanları tespit edip küçük formülü ile çözdüm son kod kilitledi. çok saolun

Rica ederim , iyi çalışmalar.

 

[Korhan Ayhan]

Alternatif olarak ÖZET TABLO (PİVOT TABLE) kullanabilirsiniz.