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

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

(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

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

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

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.

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

hayalibey

berduş

hayalibey

userx

hayalibey