• DİKKAT

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

Bir Sınıftaki Öğrencileri Yıl Sonu Geçme Notuna Göre Sıralama

  • Konbuyu başlatan Konbuyu başlatan teron
  • Başlangıç tarihi Başlangıç tarihi
T

teron

Katılım
8 Şubat 2016
Mesajlar
49
Excel Vers. ve Dili
2010
Örnek dosyaya göre "B" sayfasındaki normal listedeki notları "B-Sıralama" sayfasına yıl sonu geçme puanına (B sayfasında sarı olarak işaretledim ) göre büyükten küçüğe doğru sıralayan makro yazabilecek arkadaşların yardımına ihtiyacım var. Şimdiden Teşekkür ederim
(veri Sıralama menüsünden yapabilirdim ancak bana makro lazım )

Örnek Dosya: http://s3.dosya.tc/server15/qrkdkd/Kitap1.xlsx.html
 
Son düzenleme:
hocam biraz basit bir yöntemle sanırım çözdüm.
aşağıdaki kodu "B-sıralama" sayfasında bulunan sırala butonuna atayın
yaptığı olay "B" sayfasındaki değerleri "B-sıralama" sayfasına atıp istenilen sütündaki değerlere göre sıralama yapmak.

Kod: 
Sub Dikdörtgen2_Tıklat()
    Sheets("B-Sıralama").Range("D4:AA33").Value = Sheets("B").Range("B4:Y33").Value
    
    
    Sheets("B-Sıralama").Range("D4:AA33").Select
    Application.CutCopyMode = False
    ActiveWorkbook.Worksheets("B-Sıralama").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("B-Sıralama").Sort.SortFields.Add Key:=Range( _
        "Y4:Y33"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("B-Sıralama").Sort
        .SetRange Range("D4:AA33")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Sub[CODE]
[/CODE]
 
Merhaba.

Aşağıdaki kodu da deneyebilirsiniz.
.
Kod: 
[B]Sub Dikdörtgen2_Tıklat()[/B]
Application.ScreenUpdating = False
If Sheets("B-Sıralama").Cells(Rows.Count, [B][COLOR="Red"][SIZE="4"]6[/SIZE][/COLOR][/B]).End(3).Row > 3 Then _
    Sheets("B-Sıralama").Range("D4:AA" & Rows.Count).ClearContents
Sheets("B").Range("A3:Y" & Rows.Count).AutoFilter
Sheets("B").Range("A3:Y" & Rows.Count).AutoFilter Field:=23, Criteria1:=">=0", _
    Operator:=xlAnd, Criteria2:="<100"

Sheets("B").Range("[B][COLOR="Red"][SIZE="4"]A[/SIZE][/COLOR][/B]4:Y" & Sheets("B").Cells(Rows.Count, 1).End(3).Row).SpecialCells(xlCellTypeVisible).Copy
Sheets("B-Sıralama").[[B][COLOR="red"][SIZE="4"]C[/SIZE][/COLOR][/B]4].PasteSpecial Paste:=xlPasteValues

Sheets("B-Sıralama").Range("[B][COLOR="red"][SIZE="4"]C[/SIZE][/COLOR][/B]4:Y" & Rows.Count).Sort Sheets("B-Sıralama").[Y3], 2

Sheets("B").Range("A3:Y" & Rows.Count).AutoFilter Field:=23, Criteria1:="=", _
        Operator:=xlOr, Criteria2:="=MUAF"
Sheets("B").Range("[B][COLOR="red"][SIZE="4"]A[/SIZE][/COLOR][/B]4:Y" & Sheets("B").Cells(Rows.Count, 1).End(3).Row).SpecialCells(xlCellTypeVisible).Copy
Sheets("B-Sıralama").Cells(Sheets("B-Sıralama").Cells(Rows.Count, [B][COLOR="red"][SIZE="4"]3[/SIZE][/COLOR][/B]).End(3).Row + 1, [B][COLOR="red"][SIZE="4"]3[/SIZE][/COLOR][/B]).PasteSpecial Paste:=xlPasteValues
On Error Resume Next
Sheets("B").AutoFilterMode = False: Application.ScreenUpdating = True
[B]End Sub[/B]
 
Her iki arkadaşıma teşekkür ediyorum ancak ancak hatalar var. sıralama da kaymalar var ayrıca Muaf olanı birinci sıraya atıyo
 
Sub Bulsırala()
Dim s1 As Worksheet
Dim s2 As Worksheet
Dim i As Integer
Dim sat As Integer
Application.ScreenUpdating = False
Set s1 = Sheets("B")
Set s2 = Sheets("B-Sıralama")

s2.Range("B4:AA248").ClearContents
son = s1.Cells(6516, "A").End(3).Row

sat = 4
kes = 1
For i = 4 To son
If WorksheetFunction.IsText(s1.Range("W" & i)) And (s1.Range("W" & i) = "MUAF") Then
kat = WorksheetFunction.Min(s1.Range("W2:W" & son))
s1.Range("AA" & i).Value = (kat - kes) + (i / 1000)
kes = kes + 1
End If
If s1.Range("W" & i) = "" Then
s1.Range("AA" & i).Value = ""
End If
If WorksheetFunction.IsNumber(s1.Range("W" & i)) Then
s1.Range("AA" & i) = s1.Range("W" & i) + (i / 1000)
End If
Next i
son1 = WorksheetFunction.Count(s1.Range("AA4:AA500"))
For i = 4 To son1 + 3

t = WorksheetFunction.Large(s1.Range("AA4:AA" & son), i - 3)

k = WorksheetFunction.Match(t, s1.Range("AA4:AA" & son), 0) + 3
s2.Range("B" & sat) = s1.Range("A" & k)
s2.Range("C" & sat) = s1.Range("B" & k)
s2.Range("D" & sat) = s1.Range("C" & k)
s2.Range("E" & sat) = s1.Range("D" & k)
s2.Range("F" & sat) = s1.Range("E" & k)
s2.Range("G" & sat) = s1.Range("F" & k)
s2.Range("H" & sat) = s1.Range("G" & k)
s2.Range("I" & sat) = s1.Range("H" & k)
s2.Range("J" & sat) = s1.Range("I" & k)
s2.Range("K" & sat) = s1.Range("J" & k)
s2.Range("L" & sat) = s1.Range("K" & k)
s2.Range("M" & sat) = s1.Range("L" & k)
s2.Range("N" & sat) = s1.Range("M" & k)
s2.Range("O" & sat) = s1.Range("N" & k)
s2.Range("P" & sat) = s1.Range("O" & k)
s2.Range("Q" & sat) = s1.Range("P" & k)
s2.Range("R" & sat) = s1.Range("Q" & k)
s2.Range("S" & sat) = s1.Range("R" & k)
s2.Range("T" & sat) = s1.Range("S" & k)
s2.Range("U" & sat) = s1.Range("T" & k)
s2.Range("V" & sat) = s1.Range("U" & k)
s2.Range("W" & sat) = s1.Range("V" & k)
s2.Range("X" & sat) = s1.Range("W" & k)
s2.Range("Y" & sat) = s1.Range("X" & k)
s2.Range("Z" & sat) = s1.Range("Y" & k)


sat = sat + 1
Next i
s1.Range("AA4:AA248").Clear
s2.Range("B3").Select
Application.ScreenUpdating = True
End Sub




Bu makroda ben sadece B sayfasındaki B4 Y38 arasındaki hücrelerle ilgili işlem yapmasını istiyorum çünkü bu makroyu 245 kişilik listeleme makrosundan aldım. yani özetle ben bu makronun sadece tek bir sınıf için işlem yapmasını istiyorum
 
Verdiğim kod'u, eklediğiniz örnek belge üzerinde denediniz mi? Sorun olmaması gerekir.
.
 
Tekrar merhaba.

Önceki kod cevabımda kırmızı renklendirdiğim kısımlar değiştirildi (işlemler bir sütun öne alındı).
Sayfayı yenileyerek önceki kod cevabımı kontrol edin.
.
 
Estağfurullah, kolay gelsin.

Bir hatırlatma:
Cevaplarınıza bir formül veya kod ekleyeceğiniz zaman,
cevap yazdığınız alanın hemen üstünde sağ tarafta bulunan # karakterine fareyle tıklayın.
Formül veya kod metnini, cevap alanında oluşacak [ CODE ]...........[ /CODE ] arasına yapıştırarak/yazarak cevap oluşturursanız,
forum sayfalarını daha düzenli ve verimli kullanılmasını sağlamış olursunuz.
.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst