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

Büroya Ve Rütbeye Göre Sıralama - Baskı Önizleme

+- AccessTr.neT (https://accesstr.net)
+-- Forum: Microsoft Excel (https://accesstr.net/forum-microsoft-excel.html)
+--- Forum: Excel Cevaplanmış Soruları (https://accesstr.net/forum-excel-cevaplanmis-sorulari.html)
+--- Konu Başlığı: Büroya Ve Rütbeye Göre Sıralama (/konu-buroya-ve-rutbeye-gore-siralama.html)

Büroya Ve Rütbeye Göre Sıralama - hayalibey - 09/08/2020

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

RE: Büroya Ve Rütbeye Göre Sıralama - berduş - 09/08/2020

(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

RE: Büroya Ve Rütbeye Göre Sıralama - hayalibey - 09/08/2020

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

Re: Büroya Ve Rütbeye Göre Sıralama - userx - 09/08/2020

Sayın hayalibey
ekteki örneği inceler misiniz ?

RE: Büroya Ve Rütbeye Göre Sıralama - hayalibey - 09/08/2020

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.