Skip to main content

AccessTr.neT

Kayıt Ol

 | Facebook ile Bağlan  | Twitter İle Bağlan | Google+ İle Bağlan

Büroya Ve Rütbeye Göre Sıralama

hayalibey
hayalibey
Excel Cevaplanmış Soruları
4
821

Büroya Ve Rütbeye Göre Sıralama

Çözüldü #1
hayalibey
Aktif Üye
hayalibey
Bul
Aktif Üye
Adı Soyadı:
Konum:
Ofis Versiyonu:
Son Oturumu: 14/01/2025,07:01
Yorumları: 250
Konuları: 30
Kayıt Tarihi: 30/01/2013
Teşekkür Puanı: 0
Arkadaşlar elimde olan kodu uyarlayamadım. :Kodun çalışır hali (Rütbe ve sicile Göre Sıralama) ve olması gereken halini hem Excel dosyasında hem de resi şeklinde gösterdim. işlem yapılacak olması gerek dosya Büroya ve Rütbeye Göre Sıralama İŞLEM YAPILACAK DOSYA'dır.

Yardım edebilecek olan varsa çok sevinirim

Kod:
Sub İcmalHazırla_DurumaGöre()
Dim Alan1 As Range
Dim Alan2 As Range
    Set Sh1 = Worksheets("İcmal")
    Set Sh2 = Worksheets("KONTROL")
    Set Sh3 = Worksheets("VERİ")
    Sh1.Activate
    Sh1.Cells.Font.Bold = False
    LastColData = Sh1.Cells(1, Sh1.Cells(1, Sh1.Range("1:1").Columns.Count).End(xlToLeft).Column).Column
    LastRowData = WorksheetFunction.Max(2, Sh1.Range("A" & Rows.Count).End(xlUp).Row)
    LastColData = WorksheetFunction.Max(2, Sh1.Cells(1, Columns.Count).End(xlToLeft).Column)
    Sh1.Range(Cells(1, 2), Cells(LastRowData, LastColData + 1)).ClearContents
    Sh1.Range(Cells(2, 1), Cells(LastRowData, LastColData)).ClearContents
    For i = 2 To Sh2.Range("F1").End(xlDown).Row
        Sh1.Cells(1, i) = Sh2.Range("F" & i)
    Next i
        Sh1.Cells(1, i) = "Toplam"
    Sh1.Range(Cells(1, 2), Cells(1, i)).HorizontalAlignment = xlCenter
    Sh1.Range(Cells(1, 2), Cells(1, i)).VerticalAlignment = xlCenter
    Sh2.Range("B2:B" & Sh2.Range("B1").End(xlDown).Row).Copy
    Sh1.Range("A2").PasteSpecial xlPasteValues
    Set Alan1 = Sh3.Range("E2:E" & Sh3.Range("A1").End(xlDown).Row)
    Set Alan2 = Sh3.Range("M2:M" & Sh3.Range("A1").End(xlDown).Row)
    For i = 2 To Sh2.Range("B1").End(xlDown).Row
        For k = 2 To Sh2.Range("F1").End(xlDown).Row
            Sh1.Cells(i, k) = WorksheetFunction.CountIfs(Alan1, Sh1.Range("A" & i), Alan2, Sh1.Cells(1, k))
        Next k
        Sh1.Cells(i, k) = WorksheetFunction.Sum(Sh1.Range(Cells(i, 2), Cells(i, k - 1)))
    Next i
    Sh1.Cells(i, 1) = "Genel Toplam"
    For x = 2 To k
        Sh1.Cells(i, x) = WorksheetFunction.Sum(Sh1.Range(Cells(2, x), Cells(i, x)))
    Next x
    Rows(i).Font.Bold = True
    With Range(Cells(2, 2), Cells(i, k))
        .IndentLevel = 2
        .HorizontalAlignment = xlRight
    End With
    Range(Cells(1, 1), Cells(1, k)).Font.Bold = True
    Range(Cells(1, k), Cells(i, k)).Font.Bold = True
    Range("A1").Activate
    İcmalForm.Show
End Sub
Kod:
Private Sub İcmal_Personel_Click()
Dim Alan1 As Range
Dim Alan2 As Range
    Set Sh1 = Worksheets("İCMAL_PERSONEL")
    Set Sh2 = Worksheets("KONTROL")
    Set Sh3 = Worksheets("VERİ")
    Sh1.Activate
    Sh1.Cells.Font.Bold = False
    LastColData = Sh1.Cells(1, Sh1.Cells(1, Sh1.Range("1:1").Columns.Count).End(xlToLeft).Column).Column
    LastRowData = WorksheetFunction.Max(2, Sh1.Range("A" & Rows.Count).End(xlUp).Row)
    LastColData = WorksheetFunction.Max(2, Sh1.Cells(1, Columns.Count).End(xlToLeft).Column)
    Sh1.Range(Cells(1, 2), Cells(LastRowData, LastColData + 1)).ClearContents
    Sh1.Range(Cells(2, 1), Cells(LastRowData, LastColData)).ClearContents
    For i = 2 To Sh2.Range("A1").End(xlDown).Row
        Sh1.Cells(1, i) = Worksheets("KONTROL").Range("B" & i)
    Next i
        Sh1.Cells(1, i) = "Toplam"
    Sh1.Range(Cells(1, 2), Cells(1, i)).HorizontalAlignment = xlCenter
    Sh1.Range(Cells(1, 2), Cells(1, i)).VerticalAlignment = xlCenter
    Sh2.Range("A2:A" & Sh2.Range("B1").End(xlDown).Row).Copy
    Sh1.Range("A2").PasteSpecial xlPasteValues
    Set Alan1 = Sh3.Range("E2:E" & Sh3.Range("A1").End(xlDown).Row)
    Set Alan2 = Sh3.Range("F2:F" & Sh3.Range("A1").End(xlDown).Row)
    For i = 2 To Sh2.Range("B1").End(xlDown).Row
        For k = 2 To Sh2.Range("B1").End(xlDown).Row
            Sh1.Cells(i, k) = WorksheetFunction.CountIfs(Alan1, Sh1.Range("B" & i), Alan2, Sh1.Cells(1, k))
        Next k
        Sh1.Cells(i, k) = WorksheetFunction.Sum(Sh1.Range(Cells(i, 2), Cells(i, k - 1)))
    Next i
    Sh1.Cells(i, 1) = "Genel Toplam"
    For X = 2 To k
        Sh1.Cells(i, X) = WorksheetFunction.Sum(Sh1.Range(Cells(2, X), Cells(i, X)))
    Next X
    Rows(i).Font.Bold = True
    With Range(Cells(2, 2), Cells(i, k))
        .IndentLevel = 2
        .HorizontalAlignment = xlRight
    End With
    Range(Cells(1, 1), Cells(1, k)).Font.Bold = True
    Range(Cells(1, k), Cells(i, k)).Font.Bold = True
    Range("A1").Activate
 
 
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Unload Me
    İcmalPersonel.Show
End Sub
Bu kodlarla sıralama yapıyorum ama bu sefer de sayma işlemi ve toplama işlemini hiç yapmıyor
.rar Büroya ve Rütbeye Göre Sıralama İŞLEM YAPILACAK DOSYA.rar (Dosya Boyutu: 266,3 KB | İndirme Sayısı: 2)
.zip Büroya ve Rütbeye Göre Sıralama İŞLEM YAPILACAK DOSYA.zip (Dosya Boyutu: 271,21 KB | İndirme Sayısı: 0)
.zip Rütbe ve sicile Göre Sıralama.zip (Dosya Boyutu: 55,67 KB | İndirme Sayısı: 1)
Son Düzenleme: 09/08/2020, 12:58, Düzenleyen: hayalibey.
Cevapla
#2
berduş
Berduş
berduş
Bul
Uzman
Adı Soyadı: ha....
Konum: -
Ofis Versiyonu: Ofis 2019 64 Bit
Son Oturumu: Bugün,14:45
Yorumları: 8.506
Konuları: 94
Kayıt Tarihi: 30/07/2014
Teşekkür Puanı: 1.051
(09/08/2020, 12:57)hayalibey yazdı: dosya Büroya ve Rütbeye Göre Sıralama İŞLEM YAPILACAK DOSYA'dır.
bahsettiğiniz bağlantıdaki dosyayı indirebilmek için o siteye ücretli üyelik gerekiyor
Cevapla
#3
hayalibey
Aktif Üye
hayalibey
Bul
Aktif Üye
Adı Soyadı:
Konum:
Ofis Versiyonu:
Son Oturumu: 14/01/2025,07:01
Yorumları: 250
Konuları: 30
Kayıt Tarihi: 30/01/2013
Teşekkür Puanı: 0
Işlem yapılacak dosya
Rütbeye göre çalışan kodlar
Benim istediğim rütbeye göre olan sistemin işlem yapılacak dosyaya adapte edilmesi
Cevapla
#4
userx
Uzman
userx
Bul
Uzman
Adı Soyadı:
Konum: -
Ofis Versiyonu: Ofis 2019 32 Bit
Son Oturumu: 28/02/2024,00:48
Yorumları: 601
Konuları: 2
Kayıt Tarihi: 24/08/2009
Teşekkür Puanı: 179
Sayın hayalibey
ekteki örneği inceler misiniz ?
.rar Sıralama_userx.rar (Dosya Boyutu: 54,01 KB | İndirme Sayısı: 6)
"Dünyayı fazla düşünme."
Cevapla
#5
hayalibey
Aktif Üye
hayalibey
Bul
Aktif Üye
Adı Soyadı:
Konum:
Ofis Versiyonu:
Son Oturumu: 14/01/2025,07:01
Yorumları: 250
Konuları: 30
Kayıt Tarihi: 30/01/2013
Teşekkür Puanı: 0
Kod:
Sub icmalDurum()

Dim Alan1 As Range
Dim Alan2 As Range

Set Sh1 = Worksheets("İcmal")
Set Sh2 = Worksheets("KONTROL")
Set Sh3 = Worksheets("VERİ")

Sh1.Activate
Sh1.Cells.Font.Bold = False
Sh1.Cells.Clear

    For i = 2 To Sh2.Range("B1").End(xlDown).Row
        Sh1.Cells(1, i) = Sh2.Range("B" & i)
    Next i

Sh1.Cells(1, i) = "Toplam"
Sh1.Range(Cells(1, 2), Cells(1, i)).HorizontalAlignment = xlCenter
Sh1.Range(Cells(1, 2), Cells(1, i)).VerticalAlignment = xlCenter
Sh2.Range("A2:A" & Sh2.Range("A1").End(xlDown).Row).Copy
Sh1.Range("A2").PasteSpecial xlPasteValues

Set Alan1 = Sh3.Range("E2:E" & Sh3.Range("A1").End(xlDown).Row)
Set Alan2 = Sh3.Range("F2:F" & Sh3.Range("A1").End(xlDown).Row)

    For i = 2 To Sh1.Cells(Rows.Count, "A").End(xlUp).Row
        For k = 2 To Sh1.Cells(1, Columns.Count).End(xlToLeft).Column
            Sh1.Cells(i, k) = WorksheetFunction.CountIfs(Alan2, Sh1.Range("A" & i).Value, Alan1, Sh1.Cells(1, k).Value)
        Next k
        Sh1.Cells(i, k - 1) = WorksheetFunction.Sum(Sh1.Range(Cells(i, 2), Sh1.Cells(i, k - 2)))
    Next i
 
Sh1.Cells(i, 1) = "Genel Toplam"

    For x = 2 To k - 1
        Sh1.Cells(i, x) = WorksheetFunction.Sum(Sh1.Range(Cells(2, x), Cells(i, x)))
    Next x
 
Rows(i).Font.Bold = True

    With Range(Cells(2, 2), Cells(i, k))
        .IndentLevel = 2
        .HorizontalAlignment = xlRight
    End With

Range(Cells(1, 1), Cells(1, k)).Font.Bold = True
Range(Cells(1, k), Cells(i, k)).Font.Bold = True
Range("A1").Activate
İcmalForm.Show

End Sub
ilgilenen herkese çok teşekkür ederim. Bu kodlarla sorun çözülmüştür.
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da