Çift Tıklama İle Artan Sıralama

[hakki83]

Selamlar
Birinci satırdaki sütun başlıklarına çift tıklayarak artan sıralama yapacak kodları alabilir miyim?
Farklı alternatifler de olursa iyi olur.

 

[kulomer46]

Merhaba

Dosyanız Hazır.

Selamlar...

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'18.10.2021  10:48
If Target.Count > 1 Then Exit Sub
If Target.Row = 1 Then
    sonstr = Cells(Rows.Count, Target.Column).End(3).Row
    Columns(Target.Column).Select
        ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort.SortFields.Add Key:=Range(Cells(2, Target.Column), Cells(sonstr, Target.Column)) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort
        .SetRange Range(Cells(1, Target.Column), Cells(sonstr, Target.Column))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Cells(1, Target.Column).Select
End If
End Sub

 

[AdemCan]

Merhaba, kodlar aynı ama hazırlamışken alternatif olarak paylaşayım.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Application.ScreenUpdating = False
    Dim s As Long
    s = Cells(Rows.Count, Target.Column).End(3).Row
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add2 Key:=Range(Cells(1, Target.Column), Cells(s, Target.Column)) _
    , Order:=xlAscending
        With ActiveSheet.Sort
            .SetRange Range(Cells(2, Target.Column), Cells(s, Target.Column))
            .Orientation = xlTopToBottom
            .Apply
        End With
        s = 0
    Application.ScreenUpdating = True
End Sub

 

[hakki83]

Merhaba, kodlar aynı ama hazırlamışken alternatif olarak paylaşayım.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Application.ScreenUpdating = False
    Dim s As Long
    s = Cells(Rows.Count, Target.Column).End(3).Row
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add2 Key:=Range(Cells(1, Target.Column), Cells(s, Target.Column)) _
    , Order:=xlAscending
        With ActiveSheet.Sort
            .SetRange Range(Cells(2, Target.Column), Cells(s, Target.Column))
            .Orientation = xlTopToBottom
            .Apply
        End With
        s = 0
    Application.ScreenUpdating = True
End Sub

Emeğinize sağlık, fakat kodlar hata verdi.

 

[hakki83]

Merhaba

Dosyanız Hazır.

Selamlar...

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'18.10.2021  10:48
If Target.Count > 1 Then Exit Sub
If Target.Row = 1 Then
    sonstr = Cells(Rows.Count, Target.Column).End(3).Row
    Columns(Target.Column).Select
        ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort.SortFields.Add Key:=Range(Cells(2, Target.Column), Cells(sonstr, Target.Column)) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort
        .SetRange Range(Cells(1, Target.Column), Cells(sonstr, Target.Column))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Cells(1, Target.Column).Select
End If
End Sub

Emeğinize sağlık teşekkür ederim.
Fakat kodları sıralamayı tek sütunu değil de tüm sayfayı kapsayacak şekilde değiştirebilir misiniz? Bir de başlık hücresine çift tıklayınca tıklanan hücrenin içinde düzenleme aşamasına geçmemesi gerekiyor.

 

[AdemCan]

Rica ederim ancak kodları denemeden paylaşmıyorum, eklediğiniz dosyada sıralama işlemini yapıyor.
Uygulama yaptığınız dosyayı ve kodları tekrar paylaşır mısınız?

 

[hakki83]

Rica ederim ancak kodları denemeden paylaşmıyorum, eklediğiniz dosyada sıralama işlemini yapıyor.
Uygulama yaptığınız dosyayı ve kodları tekrar paylaşır mısınız?

Tabi, bir de sıralamayı tüm sayfayı kapsayacak şekilde ve çift tıklanan hücrede düzenleme aşamasına geçemeyecek şekilde düzenleyebilir misiniz?

 

[muygun]

Merhaba;
Soru çözümlenmiş ama alternatif olsun.
İyi çalışmalar.

 

[AdemCan]

Tabi, bir de sıralamayı tüm sayfayı kapsayacak şekilde ve çift tıklanan hücrede düzenleme aşamasına geçemeyecek şekilde düzenleyebilir misiniz?

Tüm sayfada sıralama yapması için düzenlenen kodlar.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Application.ScreenUpdating = False
    Dim s As Long, l As Integer, x As Integer
    Cancel = True
    l = Cells(1, Columns.Count).End(1).Column
    For x = 1 To l
        If Cells(1, x) <> "" Then
            s = Cells(Rows.Count, x).End(3).Row
            ActiveSheet.Sort.SortFields.Clear
            ActiveSheet.Sort.SortFields.Add2 Key:=Range(Cells(1, x), Cells(s, x)) _
            , Order:=xlAscending
                With ActiveSheet.Sort
                    .SetRange Range(Cells(1, x), Cells(s, x))
                    .Orientation = xlTopToBottom
                    .Apply
                End With
        End If
    Next
        s = 0: l = 0: x = 0
    Application.ScreenUpdating = True
End Sub

 

[hakki83]

Merhaba;
Soru çözümlenmiş ama alternatif olsun.
İyi çalışmalar.

Teşekkür ederim. Tüm sayfayı kapsayacak şekilde düzenleyebilir misiniz

 

[hakki83]

Tüm sayfada sıralama yapması için düzenlenen kodlar.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Application.ScreenUpdating = False
    Dim s As Long, l As Integer, x As Integer
    Cancel = True
    l = Cells(1, Columns.Count).End(1).Column
    For x = 1 To l
        If Cells(1, x) <> "" Then
            s = Cells(Rows.Count, x).End(3).Row
            ActiveSheet.Sort.SortFields.Clear
            ActiveSheet.Sort.SortFields.Add2 Key:=Range(Cells(1, x), Cells(s, x)) _
            , Order:=xlAscending
                With ActiveSheet.Sort
                    .SetRange Range(Cells(1, x), Cells(s, x))
                    .Orientation = xlTopToBottom
                    .Apply
                End With
        End If
    Next
        s = 0: l = 0: x = 0
    Application.ScreenUpdating = True
End Sub

Hata verdi.

 

[AdemCan]

Hata verdi diyorsunuz ama hata nedir? Hata hakkında da bilgi verir misiniz? Resim, açıklama vb.

 

[hakki83]

Hata verdi diyorsunuz ama hata nedir? Hata hakkında da bilgi verir misiniz? Resim, açıklama vb.

Tabi, çift tıklama yaptığım esnada hata veriyor,resim ekliyorum.

 

[AdemCan]

Mesajda paylaştığınız dosyalarda tekrar deneme yaptım, paylaştığım kodlar sıralama işlemi yapıyor.
Uygulama yaptığınız dosya ile paylaştığınız dosyalar aynı mı?

 

[hakki83]

Evet aynı dosyalar. 11 nolu mesajımdaki dosyayı tekrar deniyorum hata veriyor. Hiç bilemiyorum hata neden oluyor?

 

[AdemCan]

Sizin dosyanızda aynı kodların çalışma sonucu.

 

[hakki83]

Evet sizde çalışıyor. Belki excel sürümünden olabilir. Ben 2016 kullanıyorum. Bir de sizin gif resminde gördüm, diğer hücrelere de çift tıklayarak sıralama yapabiliyorsunuz. Ben ise sadece sütun başlıklarına çift tıklayarak artan sıralama yapmak istemiştim.

 

[bmutlu966]

Deneyiniz.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Intersect(Target, Range("A1:BM1")) Is Nothing Then Exit Sub
    Cancel = True
    Range("A2:BM" & Rows.Count).Sort Cells(Target.Row, Target.Column), xlAscending

End Sub

 

[hakki83]

Deneyiniz.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Intersect(Target, Range("A1:BM1")) Is Nothing Then Exit Sub
    Cancel = True
    Range("A2:BM" & Rows.Count).Sort Cells(Target.Row, Target.Column), xlAscending

End Sub

Tam olarak buydu istediğim.
Teşekkür ederim size ve ilgilenen diğer arkadaşlarımıza.