• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Çift Tıklama İle Artan Sıralama

  • Konbuyu başlatan Konbuyu başlatan hakki83
  • Başlangıç tarihi Başlangıç tarihi
hakki83

hakki83

Altın Üye
Katılım
30 Eylül 2021
Mesajlar
567
Excel Vers. ve Dili
Excel 2016 Türkçe 32 Bit
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.
 

Ekli dosyalar

Merhaba

Dosyanız Hazır.

Selamlar...

Kod: 
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
 

Ekli dosyalar

Merhaba, kodlar aynı ama hazırlamışken alternatif olarak paylaşayım.
Kod: 
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
 
faye_efsane' Alıntı:
Merhaba, kodlar aynı ama hazırlamışken alternatif olarak paylaşayım.
Kod: 
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
Genişletmek için tıkla ...
Emeğinize sağlık, fakat kodlar hata verdi.
 
kulomer46' Alıntı:
Merhaba

Dosyanız Hazır.

Selamlar...

Kod: 
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
Genişletmek için tıkla ...
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.
 
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?
 
faye_efsane' Alıntı:
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?
Genişletmek için tıkla ...
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?
 

Ekli dosyalar

hakki83' Alıntı:
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?
Genişletmek için tıkla ...
Tüm sayfada sıralama yapması için düzenlenen kodlar.
Kod: 
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
 
faye_efsane' Alıntı:
Tüm sayfada sıralama yapması için düzenlenen kodlar.
Kod: 
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
Genişletmek için tıkla ...
Hata verdi.
 

Ekli dosyalar

Hata verdi diyorsunuz ama hata nedir? Hata hakkında da bilgi verir misiniz? Resim, açıklama vb.
 
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ı?
 
Evet aynı dosyalar. 11 nolu mesajımdaki dosyayı tekrar deniyorum hata veriyor. Hiç bilemiyorum hata neden oluyor?
 
Sizin dosyanızda aynı kodların çalışma sonucu.
230935
 
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.
 
Deneyiniz.

Kod: 
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
 
bmutlu966' Alıntı:
Deneyiniz.

Kod: 
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
Genişletmek için tıkla ...
Tam olarak buydu istediğim.
Teşekkür ederim size ve ilgilenen diğer arkadaşlarımıza.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst