Soru Büroya ve Rütbeye Göre Sıralama

T

TURKOLOG

Altın Üye
Katılım
13 Kasım 2008
Mesajlar
744
Excel Vers. ve Dili
2016 64 TR
Altın Üyelik Bitiş Tarihi
29-10-2026
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
 

Ekli dosyalar

T

TURKOLOG

Altın Üye
Katılım
13 Kasım 2008
Mesajlar
744
Excel Vers. ve Dili
2016 64 TR
Altın Üyelik Bitiş Tarihi
29-10-2026
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
 
T

TURKOLOG

Altın Üye
Katılım
13 Kasım 2008
Mesajlar
744
Excel Vers. ve Dili
2016 64 TR
Altın Üyelik Bitiş Tarihi
29-10-2026
ismailem' Alıntı:
Pivottable ile birşeyler yapmaya çalıştık. Umarım Faydalı olur.
Genişletmek için tıkla ...
Hocam hem rütbeler karışık hem de benim dediğim gibi makro ile olması daha sağlıklı olacak. Ben çalışan makronun bu haline adapte edilmesini istiyorum . Ama elinize emeğinize sağlık. Çok teşekkür ederim.
 
T

TURKOLOG

Altın Üye
Katılım
13 Kasım 2008
Mesajlar
744
Excel Vers. ve Dili
2016 64 TR
Altın Üyelik Bitiş Tarihi
29-10-2026
TURKOLOG' Alıntı:
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
Genişletmek için tıkla ...

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

Bu kısımlarda bir yerde hata yapıyorum ama bulamadım. Yardım edebilecek kimse var mı
 
C

cicosz

Katılım
30 Mart 2010
Mesajlar
240
Excel Vers. ve Dili
2007,2010,2013
Altın Üyelik Bitiş Tarihi
29-05-2021
Merhaba,

İşinizi görür mü?

Edit: Toplamları yazdırırken son değişken değeri üzerinden işlem yapmışsınız. Öyle yapmaktansa tekrar dolu satır/sütun saydırıp altına/sağına toplam yazdırmak olası hataların önüne geçmek adına yapılabilir.

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.ClearContents

    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
 
T

TURKOLOG

Altın Üye
Katılım
13 Kasım 2008
Mesajlar
744
Excel Vers. ve Dili
2016 64 TR
Altın Üyelik Bitiş Tarihi
29-10-2026
Sayın @cicosz Hocam elinize emeğinize sağlık harika olmuş .
Ben dolu hücreleri tablo yaptığımdan S ve T sütunlarına sistem sanki birşeyler atıyor ki S ve T sütunları da tablo oluyor. Bunu da düzeltebilirseniz harika olacak. Elinize emeğinize sağlık yaptığınız düzenleme için.
Fazla Sütun.jpg
 
C

cicosz

Katılım
30 Mart 2010
Mesajlar
240
Excel Vers. ve Dili
2007,2010,2013
Altın Üyelik Bitiş Tarihi
29-05-2021
Merhaba,

Kod içerisindeki
Kod: 
Sh1.Cells.ClearContents
satırını
Kod: 
Sh1.Cells.Clear
şeklinde değiştirip dener misiniz?
 
T

TURKOLOG

Altın Üye
Katılım
13 Kasım 2008
Mesajlar
744
Excel Vers. ve Dili
2016 64 TR
Altın Üyelik Bitiş Tarihi
29-10-2026
cicosz' Alıntı:
Merhaba,

Kod içerisindeki
Kod: 
Sh1.Cells.ClearContents
satırını
Kod: 
Sh1.Cells.Clear
şeklinde değiştirip dener misiniz?
Genişletmek için tıkla ...
Sayın @cicosz Hocam icmal olması gerektiği gibi çalışıyor. Çok teşekkür ederim elinize emeğinize sağlık.
 
C

cicosz

Katılım
30 Mart 2010
Mesajlar
240
Excel Vers. ve Dili
2007,2010,2013
Altın Üyelik Bitiş Tarihi
29-05-2021
Merhaba,

Rica ederim. Kılavuz çizgilerini kaldırmak isterseniz
Kod: 
Sh1.Cells.Clear
satırının bir alt satırına
Kod: 
DisplayGridlines = False
satırını ekleyebilirsiniz.
 
T

TURKOLOG

Altın Üye
Katılım
13 Kasım 2008
Mesajlar
744
Excel Vers. ve Dili
2016 64 TR
Altın Üyelik Bitiş Tarihi
29-10-2026
Hocam elinize emeğinize sağlık . Çok teşekkür ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst