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 SubKod:
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
