özel sıralama

[Hacı Bayram ÖZKAN]

Merhaba arkadaşlar; ekli dosyamda sıralamaa işlemi yapılacak yalnız bu sıralama normalden farklı özel bir sıralama yardımcı olursanız sevinirim.

 

[Necdet]

Merhaba,

Özel sıralamadan kastınız nedir?

 

[Hacı Bayram ÖZKAN]

ekli dosyada açıkladım rütbeleri sıralacayak, zaten bu yapılmış, rütbeleri sıralıyor ancak, rütbe sıralanırken aynı rütbede olanları sicile göre sıralayacak, bir diğeride, aynı rütbeyi isme göre sıralayacak.

 

[Necdet]

ekli dosyada açıkladım rütbeleri sıralacayak, zaten bu yapılmış, rütbeleri sıralıyor ancak, rütbe sıralanırken aynı rütbede olanları sicile göre sıralayacak, bir diğeride, aynı rütbeyi isme göre sıralayacak.

Başkasının kodlarını anlamak kolay mı sanıyorsunuz ?

 

[Hacı Bayram ÖZKAN]

Tamam o zaman kalsın tşk.

 

[Necdet]

Merhaba,

Hemen teslim mi oluyorsunuz?

Rütbe - Sicil sıralamasını inceleyiniz

Private Sub CommandButton1_Click()
kolon = "G"
yard = "m"
For i = 2 To Cells(Rows.Count, kolon).End(3).Row
If Cells(i, kolon).Value = "3. Sınıf Emniyet Müdürü" Then Cells(i, yard).Value = Cells(i, kolon).Value: Cells(i, kolon).Value = 1
If Cells(i, kolon).Value = "4. Sınıf Emniyet Müdürü" Then Cells(i, yard).Value = Cells(i, kolon).Value: Cells(i, kolon).Value = 2
If Cells(i, kolon).Value = "Emniyet Amiri" Then Cells(i, yard).Value = Cells(i, kolon).Value: Cells(i, kolon).Value = 3
If Cells(i, kolon).Value = "Başkomiser" Then Cells(i, yard).Value = Cells(i, kolon).Value: Cells(i, kolon).Value = 4
If Cells(i, kolon).Value = "Komiser" Then Cells(i, yard).Value = Cells(i, kolon).Value: Cells(i, kolon).Value = 5
If Cells(i, kolon).Value = "Komiser Yrd." Then Cells(i, yard).Value = Cells(i, kolon).Value: Cells(i, kolon).Value = 6
If Cells(i, kolon).Value = "Başpolis Memuru" Then Cells(i, yard).Value = Cells(i, kolon).Value: Cells(i, kolon).Value = 7
If Cells(i, kolon).Value = "Polis Memuru" Then Cells(i, yard).Value = Cells(i, kolon).Value: Cells(i, kolon).Value = 8
If Cells(i, kolon).Value = "Bekçi" Then Cells(i, yard).Value = Cells(i, kolon).Value: Cells(i, kolon).Value = 9
If Cells(i, kolon).Value = "Teknisyen Yrd." Then Cells(i, yard).Value = Cells(i, kolon).Value: Cells(i, kolon).Value = 10
Next
On Error Resume Next
sat = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sut = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
[B][COLOR=red]Range(Cells(2, 1), Cells(sat, sut)).Sort Key1:=Range("G1"), Key2:=Range("D1")[/COLOR][/B]
For i = 2 To Cells(Rows.Count, kolon).End(3).Row
If Cells(i, yard).Value <> "" Then
Cells(i, kolon).Value = Cells(i, yard).Value
Cells(i, yard).Value = ""
End If
Next
End Sub

 

[Emir Hüseyin Çoban]

Tamam o zaman kalsın tşk.

. . .

Merhaba.
Size yardım etmeye çalışanlara biraz daha nazik olunuz.
En azından rütbe sıralamasını söyleyebilirdiniz.

Ekteki dosyayı inceleyiniz.
. . .

 

[Necdet]

. . .

Merhaba.
Size yardım etmeye çalışanlara biraz daha nazik olunuz.
En azından rütbe sıralamasını söyleyebilirdiniz.

Ekteki dosyayı inceleyiniz.
. . .

Biz alıştık artık böyle şeylere. Bakın birde çözüm üretiyoruz.

Olmayan Rütbeleri Diziye ekleyiniz.

Rütbe - Sicil Sıralaması

Private Sub CommandButton1_Click()
 
    Dim SonKol  As Integer, _
        SonSat  As Long, _
        i       As Long, _
        Rutbe   As Variant, _
        Sira    As Variant
 
    Rutbe = Array("1. Sınıf Emniyet Müdürü", _
                  "2. Sınıf Emniyet Müdürü", _
                  "3. Sınıf Emniyet Müdürü", _
                  "4. Sınıf Emniyet Müdürü", _
                  "Emniyet Amiri", _
                  "Başkomiser", _
                  "Komiser", _
                  "Komiser Yrd.", _
                  "Başpolis Memuru", _
                  "Polis Memuru", _
                  "Bekçi", _
                  "Teknisyen", _
                  "Teknisyen Yrd.")
 
    Application.ScreenUpdating = False
 
    SonKol = Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
    SonSat = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
 
    For i = 2 To SonSat
        Sira = Application.Match(Cells(i, "G"), Application.Transpose(Rutbe), 0)
        Cells(i, SonKol) = Sira
    Next i
 
    Range(Cells(2, 2), Cells(SonSat, SonKol)).Sort Key1:=Cells(1, SonKol), Key2:=Range("D1")
    Columns(SonKol).Delete 'Shift:=xlToLeft
 
    Application.ScreenUpdating = True
 
    MsgBox "RÜTBEYE GÖRE SIRALAMA BİTMİŞTİR...", vbInformation, "N. YEŞERTENER --> [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
 
End Sub

Rütbe - Ad - Soyad Sıralaması

Private Sub CommandButton2_Click()
 
    Dim SonKol  As Integer, _
        SonSat  As Long, _
        i       As Long, _
        Rutbe   As Variant, _
        Sira    As Variant
 
    Rutbe = Array("1. Sınıf Emniyet Müdürü", _
                  "2. Sınıf Emniyet Müdürü", _
                  "3. Sınıf Emniyet Müdürü", _
                  "4. Sınıf Emniyet Müdürü", _
                  "Emniyet Amiri", _
                  "Başkomiser", _
                  "Komiser", _
                  "Komiser Yrd.", _
                  "Başpolis Memuru", _
                  "Polis Memuru", _
                  "Bekçi", _
                  "Teknisyen", _
                  "Teknisyen Yrd.")
 
    Application.ScreenUpdating = False
 
    SonKol = Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
    SonSat = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
 
    For i = 2 To SonSat
        Sira = Application.Match(Cells(i, "G"), Application.Transpose(Rutbe), 0)
        Cells(i, SonKol) = Sira
    Next i
 
    Range(Cells(2, 2), Cells(SonSat, SonKol)).Sort Key1:=Cells(1, SonKol), Key2:=Range("B1"), Key2:=Range("C1")
    Columns(SonKol).Delete 'Shift:=xlToLeft
 
    Application.ScreenUpdating = True
 
    MsgBox "RÜTBE VE ADA GÖRE SIRALAMA BİTMİŞTİR...", vbInformation, "N. YEŞERTENER --> [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
 
End Sub

Sicil numarasına göre sıralama

Private Sub CommandButton3_Click()
 
    Dim SonKol  As Integer, _
        SonSat  As Long
 
    Application.ScreenUpdating = False
 
    SonKol = Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
    SonSat = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
 
    Range(Cells(2, 2), Cells(SonSat, SonKol)).Sort Key1:=Range("D1")
    Columns(SonKol).Delete 'Shift:=xlToLeft
 
    Application.ScreenUpdating = True
 
    MsgBox "SİCİLE GÖRE SIRALAMA BİTMİŞTİR...", vbInformation, "N. YEŞERTENER --> [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
 
End Sub

 

[Hacı Bayram ÖZKAN]

ilginize teşekkürler, kaba olduğu hiç düşünmemiştim. Sadece verilen cevaba karşı olmuyorsa kalsın demiştim. Bunda kötülük göremiyorum.