Sub XXBORC_ALACAK_YASLANDIRMA()
Set m = ThisWorkbook.Sheets("muavin"): Set r = ThisWorkbook.Sheets("RAPOR")
XDz = Timer: sm = m.Cells(Rows.Count, 1).End(3).Row
krt = CDate(m.[F1]): r.Range("A6:P" & Rows.Count).ClearContents
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
v = Array(30, 60, 90, 120, 150, 180, 210, 240, 270, 300, 330, 365, 1000)
XDv = m.Range("A4:F" & sm + 1).Value: ReDim XDsnc(1 To 16, 1 To 1)
For XD = sm - 3 To 1 Step -1
If XDv(XD, 1) <> XDv(XD + 1, 1) Then
XDsu = 4: c = c + 1: ReDim Preserve XDsnc(1 To 16, 1 To c)
XDsnc(1, c) = XDv(XD, 1): XDsnc(2, c) = XDv(XD, 2): XDsnc(16, c) = XDv(XD, 6): b = XDv(XD, 6)
If b < 0 Then: XDsu = XDsu + 1: b = -b
For XDs = XD To 1 Step -1
If XDv(XDs, XDsu) > 0 Then
x = XDv(XDs, XDsu): s = krt - CDate(XDv(XDs, 3))
For vt = 0 To UBound(v): If v(vt) >= s Then Exit For
Next
If x >= b Then: y = b: b = 0: Else y = x: b = b - y
If XDsu = 5 Then y = -y
XDsnc(vt + 3, c) = XDsnc(vt + 3, c) + y
If b = 0 Then: XD = XDs: Exit For
End If: Next: End If
Next: If c > 0 Then r.[A6].Resize(c, 16) = Application.Transpose(XDsnc)
r.Range("A6:P" & r.Cells(Rows.Count, 1).End(3).Row).Sort r.[A5], 1
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem süresi: " & Format(Timer - XDz, "0.00") & " saniye.", vbInformation, "::.. ExcelDestek.Com ..::"
End Sub