Merhaba.
Denermisiniz resimde gösterdiğim gibi sanırım ya sizinkinde yada benimkinde hata var.
https://resim.accesstr.net/do.php?img=11098
https://resim.accesstr.net/do.php?img=11099
Sub test()
Dim i As Long, son As Long, k As Long
Dim ilk As Date, ikinci As Date
Const alan As String = "D" 'D sütunu icin---O sütun icin O yazilacak sadece D yerine
Const satirBas As Byte = 4 '4.satirdan baslandigi icin
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("Sayfa1")
son = .Cells(Rows.Count, 2).End(3).Row
.Range(.Cells(satirBas, alan), .Cells(Rows.Count, .Columns(alan).Offset(, 1).Column)).Clear
If son < satirBas Then GoTo varis
For i = satirBas To son
ilk = .Cells(i, 2)
ikinci = .Cells(i, 3)
bas = WorksheetFunction.EoMonth(.Cells(i, 2).Value, -1) + 1
bitis = WorksheetFunction.EoMonth(.Cells(i, 3).Value, -1) + 1
.Cells(Rows.Count, alan).End(3)(2, 1).Value = Format(bas, "mmmm-YYYY")
.Cells(Rows.Count, alan).End(3)(1, 2).Value = Day(WorksheetFunction.EoMonth(ilk, 0)) - Day(ilk)
.Cells(Rows.Count, alan).End(3).Resize(, 2).Interior.Color = vbYellow
Do While bas <> bitis
bas = WorksheetFunction.EoMonth(bas, 0) + 1
.Cells(Rows.Count, alan).End(3)(2, 1).Value = Format(bas, "mmmm-YYYY")
.Cells(Rows.Count, alan).End(3)(1, 2).Value = Day(WorksheetFunction.EoMonth(bas, 0))
Loop
.Cells(Rows.Count, alan).End(3)(1, 2).Value = Day(WorksheetFunction.EoMonth(ikinci, 0)) - Day(ikinci)
.Cells(Rows.Count, alan).End(3).Resize(, 2).Interior.Color = vbYellow
Next
.Columns(alan).Offset(, 1).HorizontalAlignment = xlCenter
End With
MsgBox "Bitti", vbInformation
Exit Sub
varis:
Application.ScreenUpdating = True
MsgBox "Hata", vbCritical
End Sub
