• DİKKAT

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

özel sıralama

H

Hacı Bayram ÖZKAN

Katılım
24 Şubat 2009
Mesajlar
1,077
Excel Vers. ve Dili
2016
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.
 

Ekli dosyalar

Merhaba,

Özel sıralamadan kastınız nedir?
 
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.
 
tarzanhaci' Alıntı:
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.
Genişletmek için tıkla ...

Başkasının kodlarını anlamak kolay mı sanıyorsunuz ? :)
 
Merhaba,

Hemen teslim mi oluyorsunuz?

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

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

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

Ekteki dosyayı inceleyiniz.
. . .
Genişletmek için tıkla ...

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ı

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

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


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

Ekli dosyalar

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.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst