Create Entries on another sheet based on frequencies

Woo... that was not as small a task as I first envisioned. There is some hidden traps here with each data type, so hopefully this gives you what you want AND takes care of those off years where December has more pay weeks than normal, Weekly and Bi-Weekly specifically at issue.

Option Explicit

Sub AddYearlyEntries()
Dim Dates As Range, MyDate As Range, NR As Long, rws As Long, DateRw As Long, ChkDate As Range

Set Dates = Sheets("Budget Input UI").Range("F:F").SpecialCells(xlConstants, xlNumbers)
With Sheets("Budget Entries")
    For Each MyDate In Dates
        NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1
        Select Case LCase(MyDate.Offset(, -1))
            Case "weekly":          rws = 52
            Case "bi-weekly":       rws = 26
            Case "semi-monthly":    rws = 24
            Case "monthly":         rws = 12
            Case "bi-monthly":      rws = 6
            Case "quarterly":       rws = 4
            Case "semi-annually":   rws = 2
            Case "annually":        rws = 1
        End Select
        .Range("A" & NR & ":C" & NR).Resize(rws).Value = MyDate.Offset(, -5).Resize(, 3).Value
        .Range("D" & NR).Value = MyDate.Value
        .Range("E" & NR).Resize(rws).Value = MyDate.Offset(, -2).Value
        .Range("F" & NR).Resize(rws).Value = MyDate.Offset(, 1).Value
        For DateRw = NR + 1 To NR + rws - 1
            Set ChkDate = .Range("D" & DateRw - 1)
            Select Case LCase(MyDate.Offset(, -1))
                Case "weekly"
                    .Range("D" & DateRw).Value = ChkDate.Value + 7
                    If .Range("A" & DateRw + 1) = "" Then
                        If Day(.Range("D" & DateRw).Value) = 24 Then
                            .Range("A" & DateRw).EntireRow.Copy .Range("A" & DateRw + 1)
                            .Range("D" & DateRw + 1).Value = ChkDate + 14
                        End If
                    End If
                Case "bi-weekly"
                    .Range("D" & DateRw).Value = ChkDate.Value + 14
                    If .Range("A" & DateRw + 1) = "" Then
                        If Day(ChkDate.Value) <= 3 Then
                            .Range("A" & DateRw).EntireRow.Copy .Range("A" & DateRw + 1)
                            .Range("D" & DateRw + 1).Value = ChkDate + 28
                        End If
                    End If
                Case "semi-monthly"
                    Select Case Day(ChkDate)
                        Case 1 To 14
                            .Range("D" & DateRw).Value = ChkDate.Value + 14
                        Case Else
                            .Range("D" & DateRw).Value = DateSerial(Year(ChkDate.Offset(-1)), Month(ChkDate.Offset(-1)) + 1, Day(ChkDate.Offset(-1)))
                    End Select
                Case "monthly"
                    .Range("D" & DateRw).Value = DateSerial(Year(ChkDate), Month(ChkDate) + 1, Day(ChkDate))
                Case "bi-monthly"
                    .Range("D" & DateRw).Value = DateSerial(Year(ChkDate), Month(ChkDate) + 2, Day(ChkDate))
                Case "quarterly"
                    .Range("D" & DateRw).Value = DateSerial(Year(ChkDate), Month(ChkDate) + 3, Day(ChkDate))
                Case "semi-annually"
                    .Range("D" & DateRw).Value = DateSerial(Year(ChkDate), Month(ChkDate) + 6, Day(ChkDate))
                Case "annually"
                    'do nothing
            End Select
        Next DateRw
    Next MyDate
    .Range("D:D").NumberFormat = "mm/dd/yy"
    .Range("F:F").Style = "Currency"
    .Range("A:F").Sort .Range("D2"), xlAscending, .Range("E2"), , xlAscending, Header:=xlYes
    .Columns.AutoFit
End With
End Sub

Hi Catnam,

Try this:

Sub Catnam(): Dim Typ As String, Cat As String, Sct As String, Pyr As String
Dim FDD As Date, Amt As Single, p As Long, q As Long, r As Long, er As Long
Dim wi As Worksheet, we As Worksheet, F, T, i As Integer, n As Integer

F = Array(" ", "weekly", "bi-weekly", "bi-monthly", "semi-monthly", _
                    "monthly", "quarterly", "semi-annually", "annually")
T = Array(0, 52, 26, 24, 12, 6, 4, 2, 1)

Set we = ActiveWorkbook.Sheets("Budget Entries")
we.Range("F:F").NumberFormat = "0.00"
Set wi = ActiveWorkbook.Sheets("Budget Input UI ") 'a space after UI here
er = 4: Do Until wi.Cells(er + 1, 1) = "": er = er + 1: Loop: q = 1

LoadIns:

For r = 4 To er
Typ = wi.Cells(r, 1): Cat = wi.Cells(r, 2): Sct = wi.Cells(r, 3)
Pyr = wi.Cells(r, 4): FDD = wi.Cells(r, 6): Amt = wi.Cells(r, 7)

For i = 1 To UBound(F)
If LCase(wi.Cells(r, 5)) = F(i) Then
n = Int(365 / T(i) + 0.5): Exit For: End If
Next i: p = T(i) - 1

For i = 0 To p: q = q + 1
we.Cells(q, 1) = Typ: we.Cells(q, 2) = Cat: we.Cells(q, 3) = Sct
we.Cells(q, 4) = FDD + i * n: we.Cells(q, 5) = Pyr: we.Cells(q, 6) = Amt
Next i
Next r

we.Cells.sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlYes

End Sub

Yes, I had that problem, too. Your sheet name has a hidden space at the end, take that out.

"Budget Input UI "

If that takes care of your original question, please select Thread Tools from the menu link above and mark this thread as SOLVED. Thanks.