Çözüldü Makronun kendiliğinden sıralama yapabilmesi

[Beşir TÜRK]

Ekteki belgemde aşağıdaki işlemi yapan bir makro koduna ihtiyacım var.

C3: D17 arasındaki verileri C3:C17 sütunundaki değerleri baz alarak küçükten büyüğe makro ile sıralamak istiyorum.
Makro bir butonla değil kendi kendine bu sıralamayı yapsa çok iyi olur. Diğer deyişle C sütununa değer yazdıkça ilgili veri sırasına kendiliğinden gitsin.
Teşekkürler.
https://we.tl/t-zVnMAGeUh1

 

[Ömer BARAN]

Merhaba.

Alt taraftan uygulamanın yapılacağı sayfanın adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin.
açılacak VBA ekranında sağdaki boş alana aşağıdaki kod blokunu yapıştırın.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C3:C17]) Is Nothing Then Exit Sub
[C3:D17].Sort [C2], 1
End Sub

 

[Muzaffer Ali]

Merhaba.
Alternatif olsun.
Sayfa adını sağ tıklatın "Kod Görüntüle" seçin açılan sayfaya aşağıdaki kodları yapıştırın.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim SatirSay As Long
    If Intersect(Target, Range("C:C")) Is Nothing Then Exit Sub
    SatirSay = Cells(Rows.Count, "C").End(3).Row
    With ActiveSheet.Sort
        .SortFields.Add Key:=Range("C3:C" & SatirSay), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("B3:D" & SatirSay) ' Eğer sutunlar daha fazla olacaksa bu satırsaki "D" yi değiştirebilirsiniz.
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

 

[Beşir TÜRK]

Ömer BARAN ve dalgalikur iki kod da güzel bir şekilde çalışıyor. Teşekkürler.
Bu sıralamayı büyükten küçüğe yapmak istesem kodlarda neresi değişmelidir.

 

[Tevfik_Kursun]

Merhaba,
Ömer Hocanın kodunda 1 i 2 yapınız
Dalgalıkur Hocanın kodunda Order:=xlAscending ifadesini Order:=xlDescending yapınız
İyi çalışmalar

 

[Tevfik_Kursun]

Muhterem Hocalarım,
Ben de araya bir soru atayım, burada önce D sütundaki hücreyi doldurup sonra C sütundaki hücreyi doldurursanız birlikte sıraya giriyor. Yoksa D sütunundaki hücre boşta olsa hepsi C sütununa göre sıraya giriyor.
Atlamayı engellemek için C yi ve D yi doldurduktan sonra entere basıp aşağı geçtiğinde tetiklemenin bir yolu var mıdır?
Saygılarımla

 

[Muzaffer Ali]


If Intersect(Target, Range("C:C")) Is Nothing Then Exit Sub

buradaki "C:C" yi "D:D" yaparsanız D sutünunda bir değişiklik olduğunda tetiklenir.

 

[Ömer BARAN]

Ben ise şöyle düşündüm.
Boş olan hücre hangisiyse (C veya D sütununda) o hücre seçili hale gelir.
İkiside doluysa sıralama yapılır.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C3:D17]) Is Nothing Then Exit Sub
dolu = WorksheetFunction.CountBlank(Range("C" & Target.Row & ":D" & Target.Row)) Mod 2
If dolu = 0 Then [C3:D17].Sort [C2], 1
If Cells(Target.Row, "C") = "" Then Cells(Target.Row, "C").Activate
If Cells(Target.Row, "D") = "" Then Cells(Target.Row, "D").Activate
End Sub

 

[Tevfik_Kursun]

Her ikinize de ayrı ayrı teşekkür ederim.
Saygılarımla

 

[Beşir TÜRK]

Tevfik_Kursun kardeşim
5. mesaj: Dalgalıkur Hocanın kodunda Order:=xlAscending ifadesini Order:=xlDescending yapınız
Burayı yapamadım veya olmuyor.

 

[Tevfik_Kursun]

Buyrun ...

 

[Beşir TÜRK]

Kodu paylaşabilir misiniz? Göremiyorum.

 

[Tevfik_Kursun]

Sayfanın içinde arkadaşım.
Sayfa3 yazısının üzerine mouse ile gelip sağ tuş yapın Kod Görüntüle sekmesini tıklayın
karşınıza çıkacak

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim SatirSay As Long
    If Intersect(Target, Range("D:D")) Is Nothing Then Exit Sub
    SatirSay = Cells(Rows.Count, "C").End(3).Row
    With ActiveSheet.Sort
        .SortFields.Add Key:=Range("C3:C" & SatirSay), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .SetRange Range("C3:D" & SatirSay) ' Eğer sutunlar daha fazla olacaksa bu satırsaki "D" yi değiştirebilirsiniz.
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

iyi çalışmalar

 

[Beşir TÜRK]

Üyeliğim olmadığından dosyayı indirememiştim.
Teşekkür ederim.

 

[Tevfik_Kursun]

Fark etmemişim
https://drive.google.com/open?id=166Wtyxc28RS-uX-blxijUJGWdUoSZhkJ