Skip to main content

AccessTr.neT


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

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

Çözüldü #1
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
(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
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
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
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
Task