Private Sub test()
Const kolPridays& = 30, NimrDAyofweek& = 5
Dim d1 As Date
d1 = Date
Sheets("Лист1").Cells(1, 4).Value = d1
MakeFriday d1, kolPridays, NimrDAyofweek
End Sub
Private Sub MakeFriday(ddate As Date, kolPridays&, NimrDAyofweek&)
On Error GoTo handle1
Const firstPaument& = 3
Dim kolPtn&, d1 As Date, nomrofday&
kolPtn = 0: d1 = ddate
Do Until kolPtn = kolPridays
d1 = DateAdd("y", 1, d1)
nomrofday = Weekday(d1, vbMonday) ' monday is first
If nomrofday = NimrDAyofweek Then
If kolPtn = 0 Then' если до следующего платежа количество дней меньше firstPaument переносим его
    If DateDiff("y", ddate, d1, vbMonday) < firstPaument Then GoTo go1
End If
kolPtn = kolPtn + 1: Sheets("Лист1").Cells(1 + kolPtn, 4).Value = d1
go1:
End If
Loop
Exit Sub
handle1: ' look any problem
Stop
Resume
End Sub