nongeyikm
Altın Üye
- Katılım
- 7 Kasım 2005
- Mesajlar
- 495
- Excel Vers. ve Dili
- Office 365 TR-64
- Altın Üyelik Bitiş Tarihi
- 15-04-2025
Merhabalar,
Aşağıdaki modülü yine sizler yapmıştınız.
Modülde, "X" ler sayılmakta. "BÇ" ve "PÇ" lerin de sayılmasını istiyorum. (X, BÇ,PÇ toplamı)
Desteğiniz için şimdiden teşekkür ederim.
Saygılarımla,
Sub ICMAL()
Set i = Sheets("İCMAL")
i.Range("B12:AD86").ClearContents
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
For shf = 1 To Sheets.Count
If Sheets(shf).Name <> "İCMAL" Then _
Sheets(shf).Range("B12:E86").Copy i.Cells(i.Cells(Rows.Count, "YA").End(3).Row + 1, "YA")
Next
ison = i.Cells(Rows.Count, "YA").End(3).Row
i.Range("YA2:YD" & ison).Sort i.[YA1], xlAscending
i.Range("YA2:YD" & ison).RemoveDuplicates Columns:=1, Header:=xlNo
i.Range("YA2:YD" & i.Cells(Rows.Count, "YA").End(3).Row).Copy
i.[B12].PasteSpecial Paste:=xlPasteValues
i.Range("YA2:YD" & ison).Clear
For sat = 12 To i.[B11].End(xlDown).Row
For shf = 1 To ThisWorkbook.Worksheets.Count
If Sheets(shf).Name <> "İCMAL" Then
sson = Sheets(shf).[B11].End(xlDown).Row
If WorksheetFunction.CountIf(Sheets(shf).Range("B12:B" & sson), i.Cells(sat, "B")) > 0 Then
ssat = WorksheetFunction.Match(i.Cells(sat, "B"), Sheets(shf).Range("B12:B" & sson), 0)
For sut = 6 To 27
If Sheets(shf).Cells(ssat + 11, sut) = "X" Then
say = say + 1
If say > 0 Then i.Cells(sat, sut) = i.Cells(sat, sut) + say: say = 0
ElseIf IsNumeric(Sheets(shf).Cells(ssat + 11, sut)) Then
deg = deg + Sheets(shf).Cells(ssat + 11, sut)
If deg > 0 Then i.Cells(sat, sut) = i.Cells(sat, sut) + deg: deg = 0
End If
Next
End If
End If
Next
Next
i.[A9].Activate
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "Bence tamam", vbInformation, "oldu mu?"
End Sub
Aşağıdaki modülü yine sizler yapmıştınız.
Modülde, "X" ler sayılmakta. "BÇ" ve "PÇ" lerin de sayılmasını istiyorum. (X, BÇ,PÇ toplamı)
Desteğiniz için şimdiden teşekkür ederim.
Saygılarımla,
Sub ICMAL()
Set i = Sheets("İCMAL")
i.Range("B12:AD86").ClearContents
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
For shf = 1 To Sheets.Count
If Sheets(shf).Name <> "İCMAL" Then _
Sheets(shf).Range("B12:E86").Copy i.Cells(i.Cells(Rows.Count, "YA").End(3).Row + 1, "YA")
Next
ison = i.Cells(Rows.Count, "YA").End(3).Row
i.Range("YA2:YD" & ison).Sort i.[YA1], xlAscending
i.Range("YA2:YD" & ison).RemoveDuplicates Columns:=1, Header:=xlNo
i.Range("YA2:YD" & i.Cells(Rows.Count, "YA").End(3).Row).Copy
i.[B12].PasteSpecial Paste:=xlPasteValues
i.Range("YA2:YD" & ison).Clear
For sat = 12 To i.[B11].End(xlDown).Row
For shf = 1 To ThisWorkbook.Worksheets.Count
If Sheets(shf).Name <> "İCMAL" Then
sson = Sheets(shf).[B11].End(xlDown).Row
If WorksheetFunction.CountIf(Sheets(shf).Range("B12:B" & sson), i.Cells(sat, "B")) > 0 Then
ssat = WorksheetFunction.Match(i.Cells(sat, "B"), Sheets(shf).Range("B12:B" & sson), 0)
For sut = 6 To 27
If Sheets(shf).Cells(ssat + 11, sut) = "X" Then
say = say + 1
If say > 0 Then i.Cells(sat, sut) = i.Cells(sat, sut) + say: say = 0
ElseIf IsNumeric(Sheets(shf).Cells(ssat + 11, sut)) Then
deg = deg + Sheets(shf).Cells(ssat + 11, sut)
If deg > 0 Then i.Cells(sat, sut) = i.Cells(sat, sut) + deg: deg = 0
End If
Next
End If
End If
Next
Next
i.[A9].Activate
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "Bence tamam", vbInformation, "oldu mu?"
End Sub