Excel 2007 VBA copy rows x times based on text filter

Question

I'm new to VBA and can;t wrap my head around the most efficient way to do this - what I'm looking for is a way to copy my data into rows below the active cell based upon a frequency.

Sample data is like this:

Name     Value  Frequency   Date
Steve    10     Annual      01/03/2012 
Dave     25     Quarterly   01/03/2012 
Sarah    10     Monthly     01/03/2012 
Gavin    27     Quarterly   01/04/2012

And what I would like to do in this case is for Sarah add in all rows in one month increments until March 2013. This would mean adding in 12 rows, from April 2012 to March 2013, With the name, value and frequency remaining constant.

For Steve I would like to add in one row for March 2013 For Dave I would like to add in 3 rows (one every three months)

If the first date were to be 1st April 2012 instead, and the frequency annual. I would like to add in nothing as there is no other date before March 2013.

For the above sample the output would be:

Name    Value   Frequency   Date
Steve   10  Annual      01/03/2012
Steve   10  Annual      01/03/2013
Dave    25  Quarterly   01/03/2012
Dave    25  Quarterly   01/07/2012
Dave    25  Quarterly   01/11/2012
Dave    25  Quarterly   01/03/2013
Sarah   10  Monthly     01/03/2012
Sarah   10  Monthly     01/04/2012
Sarah   10  Monthly     01/05/2012
Sarah   10  Monthly     01/06/2012
Sarah   10  Monthly     01/07/2012
Sarah   10  Monthly     01/08/2012
Sarah   10  Monthly     01/09/2012
Sarah   10  Monthly     01/10/2012
Sarah   10  Monthly     01/11/2012
Sarah   10  Monthly     01/12/2012
Sarah   10  Monthly     01/01/2013
Sarah   10  Monthly     01/02/2013
Sarah   10  Monthly     01/03/2013
Gavin   27  Quarterly       01/04/2012
Gavin   27  Quarterly       01/08/2012
Gavin   27  Quarterly       01/12/2012

Thanks in advance!

Answer 1

Davin

Wilhelm, asked a valid question. I am still going ahead and assuming that by saying 'Quarterly' you just want to add 4 months.

I am also assuming that (I guess I am correct on this one though) you want to keep on incrementing the dates till the time they are less than 1st March 2013 (immaterial of the fact whether it is ANNUAL, QUARTERLY or MONTHLY)

Please try this code. I am sure it can be made more perfect. ;)

TRIED AND TESTED

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

Answer 2

You need a function that translate the frequency text to a number of months (let´s call it MonthFreq returning an integer).

This will do what you want:

MaxDate = DateSerial(2013, 4, 1)
Do Until Origin.Cells(OriginRow, NameColumn).Value = ""
    SourceDate = Origin.Cells(OriginRow, DateColumn).Value
    Do Until SourceDate >= MaxDate
        ' Copy origin row to destiny.
        Destiny.Cells(DestinyRow, DateColumn).Value = SourceDate

        SourceDate = DateAdd("m", MonthFreq(Origin.Cells(OriginRow, FreqColumn).Value), SourceDate)
        DestinyRow = DestinyRow + 1
    Loop
    OriginRow = OriginRow + 1
Loop

Origin is the worksheet with the original data, Destiny is the worksheet where the expanded data will be saved. OriginRow is the current row being analyzed in the Origin worksheet (starts at the first row). OriginColumn is the current row being written in the Destiny worksheet (starts at the first row). SourceDate will be added some number of months until it reaches the MaxDate.