Дэвин
Вильгельм, задал правильный вопрос. Я все еще продолжаю и предполагаю, что, говоря «Ежеквартально», вы просто хотите добавить 4 месяца.
Я также предполагаю, что ( Я полагаю, что я прав в этом, хотя ) вы хотите продолжать увеличивать даты до того времени, когда они будут меньше 1 марта 2013 года (неважно, является ли это ЕЖЕГОДНО, КВАРТАЛЬНО или ЕЖЕМЕСЯЧНО)
Пожалуйста, попробуйте этот код. Я уверен, что это можно сделать более совершенным. ;)
ПРОВЕРЕНО И ИСПЫТАНО
Option Explicit
Sub Sample()
Dim ws As Worksheet, ws1 As Worksheet
Dim i As Long, j As Long, LastRow As Long
Dim boolOnce As Boolean
Dim dt As Date
On Error GoTo Whoa
Application.ScreenUpdating = False
'~~> Input Sheet
Set ws = Sheets("Sheet1")
'~~> Output Sheet
Set ws1 = Sheets("Sheet2")
ws1.Cells.ClearContents
'~~> Get the last Row from input sheet
LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
boolOnce = True
'~~> Loop through cells in Col A in input sheet
For i = 2 To LastRow
j = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row + 1
Select Case UCase(ws.Range("C" & i).Value)
Case "ANNUAL"
dt = DateAdd("yyyy", 1, ws.Range("D" & i).Value)
'~~> Check if the date is less than 1st march 2013
If dt <= #3/1/2013# Then
ws1.Range("A" & j & ":A" & j + 1).Value = ws.Range("A" & i).Value
ws1.Range("B" & j & ":B" & j + 1).Value = ws.Range("B" & i).Value
ws1.Range("C" & j & ":C" & j + 1).Value = ws.Range("C" & i).Value
ws1.Range("D" & j).Value = ws.Range("D" & j).Value
ws1.Range("D" & j + 1).Value = DateAdd("yyyy", 1, ws.Range("D" & i).Value)
End If
Case "QUARTERLY"
dt = DateAdd("M", 4, ws.Range("D" & i).Value)
Do While dt <= #3/1/2013#
ws1.Range("A" & j).Value = ws.Range("A" & i).Value
ws1.Range("B" & j).Value = ws.Range("B" & i).Value
ws1.Range("C" & j).Value = ws.Range("C" & i).Value
If boolOnce = True Then
ws1.Range("D" & j).Value = DateAdd("M", -4, dt)
boolOnce = False
Else
ws1.Range("D" & j).Value = dt
End If
dt = DateAdd("M", 4, ws1.Range("D" & j).Value)
j = j + 1
Loop
boolOnce = True
Case "MONTHLY"
dt = DateAdd("M", 1, ws.Range("D" & i).Value)
Do While dt <= #3/1/2013#
ws1.Range("A" & j).Value = ws.Range("A" & i).Value
ws1.Range("B" & j).Value = ws.Range("B" & i).Value
ws1.Range("C" & j).Value = ws.Range("C" & i).Value
If boolOnce = True Then
ws1.Range("D" & j).Value = DateAdd("M", -1, dt)
boolOnce = False
Else
ws1.Range("D" & j).Value = dt
End If
dt = DateAdd("M", 1, ws1.Range("D" & j).Value)
j = j + 1
Loop
boolOnce = True
End Select
Next i
LetsContinue:
Application.ScreenUpdating = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
Snapshot
