Sıralama Koduna İlave

[1Al2Ver]

Merhaba,

Aşağıdaki kod, "KAYITLAR" sayfası için işlem yapmaktadır,

Bu koda, "İSTANBUL", "YALOVA", "TEKİRDAĞ", "EDİRNE", "KIRKLARELİ", "BURSA", "ÇANAKKALE", "KOCAELİ", "SAKARYA" isimli sayfaları da ilave etmek istiyorum,

Adı geçen sayfalardaki işlem aralıkları aynıdır ( B2:AA, AC2:AC gibi )

Kısaca, tek makro ile, KAYITLAR ve İSTANBUL, YALOVA, TEKİRDAĞ, EDİRNE, KIRKLARELİ, BURSA, ÇANAKKALE, KOCAELİ, SAKARYA isimli sayfaların "AC" sütununu sıralatmak istiyorum.

Teşekkür ederim.

Sub Benzersiz_Sırala_KAYITLAR()
  Dim Liste()
    If MsgBox("KAYITLAR Sayfası AC SÜTUNU Güncellenecek !", vbYesNo, "DİKKAT!") = vbNo Then Exit Sub
    Veri = Range("B2:AA" & Range("B" & Rows.Count).End(3).Row).Value
    ReDim Liste(1 To UBound(Veri), 1 To 1)
    For i = 1 To UBound(Veri)
        If Veri(i, UBound(Veri, 2)) <> 1 Then
            Say = Say + 1
            Liste(Say, 1) = Veri(i, 1)
        End If
    Next i
    Range("AC2:AC" & Rows.Count).ClearContents
    Range("AC2").Resize(Say, 1) = Liste
End Sub

 

[AdemCan]

Merhaba dener misiniz?
Her sayfa için mesaj uyarısı çıksın isterseniz bu kodu kullanın.

Sub Benzersiz_Sırala_KAYITLAR()
Dim Liste()
sayfa = Array("KAYITLAR", "İSTANBUL", "YALOVA", "TEKİRDAĞ", "EDİRNE", "KIRKLARELİ", "BURSA", "ÇANAKKALE", "KOCAELİ", "SAKARYA")
For s = 0 To UBound(sayfa)
    If MsgBox(sayfa(s) & " Sayfası AC SÜTUNU Güncellenecek !", vbYesNo, "DİKKAT!") = vbNo Then
        GoTo gec
    Else
        Veri = Sheets(sayfa(s)).Range("B2:AA" & Sheets(sayfa(s)).Range("B" & Rows.Count).End(3).Row).Value
        ReDim Liste(1 To UBound(Veri), 1 To 1)
        For i = 1 To UBound(Veri)
            If Veri(i, UBound(Veri, 2)) <> 1 Then
                say = say + 1
                Liste(say, 1) = Veri(i, 1)
            End If
        Next i
    Sheets(sayfa(s)).Range("AC2:AC" & Rows.Count).ClearContents
    Sheets(sayfa(s)).Range("AC2").Resize(say, 1) = Liste
End If
gec:
i = 1: say = 0
Next s
End Sub

Mesaj kutusu çıksın istemezseniz de bu kodu kullanın. ( Aynı kod içerisinde mesaj kutusu pasif olarak bırakıldı. )

Sub Benzersiz_Sırala_KAYITLAR()
Dim Liste()
sayfa = Array("KAYITLAR", "İSTANBUL", "YALOVA", "TEKİRDAĞ", "EDİRNE", "KIRKLARELİ", "BURSA", "ÇANAKKALE", "KOCAELİ", "SAKARYA")
For s = 0 To UBound(sayfa)
'    If MsgBox(sayfa(s) & " Sayfası AC SÜTUNU Güncellenecek !", vbYesNo, "DİKKAT!") = vbNo Then
'        GoTo gec
'    Else
        Veri = Sheets(sayfa(s)).Range("B2:AA" & Sheets(sayfa(s)).Range("B" & Rows.Count).End(3).Row).Value
        ReDim Liste(1 To UBound(Veri), 1 To 1)
        For i = 1 To UBound(Veri)
            If Veri(i, UBound(Veri, 2)) <> 1 Then
                say = say + 1
                Liste(say, 1) = Veri(i, 1)
            End If
        Next i
    Sheets(sayfa(s)).Range("AC2:AC" & Rows.Count).ClearContents
    Sheets(sayfa(s)).Range("AC2").Resize(say, 1) = Liste
'End If
gec:
i = 1: say = 0
Next s
End Sub

 

[1Al2Ver]

Sayın AdemCan, merhaba,

Öncelikle duyarlığınız ve çözümler için çok teşekkür ederim, sağ olun, kodlar mükemmel çalışıyor,

Bu koda End Sub'dan önce aşağıdaki gibi bir kod ile Alfabetik sıralama (A:Z) yaptırmak istedim, tabi başaramadım,

Düzenlerseniz memnun olurum,

Teşekkür ederim.

Sub Alfabetik_Sırala_Tüm_Sayfalar()
    Dim Sayfalar As Variant
    Dim Sayfa As Integer
    If MsgBox("KAYITLAR ve Tüm Sayfalar AC Sütunu Alfabetik Sıralanacak !", vbYesNo, "DİKKAT !") = vbNo Then Exit Sub
    Sayfalar = Array("KAYITLAR", "İSTANBUL", "YALOVA", "TEKİRDAĞ", "EDİRNE", "KIRKLARELİ", "BURSA", "ÇANAKKALE", "KOCAELİ", "SAKARYA")
    For Sayfa = 0 To UBound(Sayfalar)
        With ThisWorkbook.Worksheets(Sayfalar(Sayfa))
    Range("AC2:AC500").Select
    
    ActiveWindow.SmallScroll Down:=-37
    Selection.Sort Key1:=Range("AC2"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        End With
    Next
End Sub

 

[AdemCan]

Dener misiniz?

Sub Alfabetik_Sırala_Tüm_Sayfalar()
    Dim Sayfalar As Variant
    Dim Sayfa As Integer
    If MsgBox("KAYITLAR ve Tüm Sayfalar AC Sütunu Alfabetik Sıralanacak !", vbYesNo, "DİKKAT !") = vbNo Then Exit Sub
    Sayfalar = Array("KAYITLAR", "İSTANBUL", "YALOVA", "TEKİRDAĞ", "EDİRNE", "KIRKLARELİ", "BURSA", "ÇANAKKALE", "KOCAELİ", "SAKARYA")
    For Sayfa = 0 To UBound(Sayfalar)
        With ThisWorkbook.Worksheets(Sayfalar(Sayfa)).Sort
            .SortFields.Clear
            .SortFields.Add2 Key:=Worksheets(Sayfalar(Sayfa)).Range("AC2:AC500"), Order:=xlAscending
            .SetRange Worksheets(Sayfalar(Sayfa)).Range("B2:AC500")
            .Header = xlGuess
            .Apply
        End With
    Next
End Sub

 

[1Al2Ver]

Sayın AdemCan tekrar merhaba,

Çok teşekkür ederim, emeğiniz sağlık,

Sevgi ve saygılarımla.

 

[AdemCan]

Rica ederim, iyi çalışmalar.