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!

This looks like a nightmare to me, the code you require isn't difficult BUT.... Readability, practicality, layout and maintenance are questionable. Consider changing your design, perhaps spreading over multiple sheets and using one table of raw data and presentation on another(s). — Reafidy, Feb 02 '12 at 02:58
@Wilhelm - absolutely (wrote this at the end of a long day!) — Dibstar, Feb 02 '12 at 08:21
@Reafidy - perhaps the simplest implementation of this would be to have a function which only does this for the active cell, where we are looking at the data at the bottom? — Dibstar, Feb 02 '12 at 08:46

score 1 · Answer 1 · answered Feb 01 '12 at 20:11

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.

Thanks for this - forgive my ignorance but say my origin cell was simply the active cell and I wanted to paste the data in the rows directly below it - i.e. for my example of Dave (quarterly) if the active cell is A10, I would like to paste the three additional rows of data below this? — Dibstar, Feb 02 '12 at 08:41
Don't lose your input data. Correction may be more difficult later. The output worksheet will have your original data anyway. — Wilhelm, Feb 02 '12 at 18:04

score 1 · Accepted Answer · answered Feb 02 '12 at 01:53

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

enter image description here

Thanks for this - the quarterly value was an error on my part, but I think given the structure it shouldn't be too tough to deal with! I have tested it and it does work, I just have to work out how it does its magic! :) — Dibstar, Feb 02 '12 at 08:36
Would it be possible to ask how to use this function to also / instead just do this for the last row of data and paste underneath (so based on the sample use A5 as the active cell and past the 2 rows in A6 and A7)? Thanks! — Dibstar, Feb 02 '12 at 08:48
Davin, this is where I am looping through the cells "For i = 2 To LastRow" you can always set it for A5. I am using the ws1 as the 2nd sheet for output. You can direct that to the current sheet :) — Siddharth Rout, Feb 02 '12 at 12:16
Sorry for ignorance here, but if I wanted A5 to be the active cell rather than a specific reference, and pasting the rows underneath (so taking it one case at a time instead), how would I modify the "For i=2 to lastrow" bit? Thanks :) — Dibstar, Feb 02 '12 at 12:47
I can give you the answer but I want you to first understand the code :). "For i=2 to lastrow" loops from cell A2 to A(Lastrow). So If I just want to interact with A5 then what should we do? How should we write it so that it addresses only cell A5? — Siddharth Rout, Feb 02 '12 at 13:59
@siddarth - I see! sorry for the stupidity, I didn't realised you could concatenate a cell reference like that within the VBA, I presume then that you could just write i = 5. But what I was wondering was how to change it to reference the active cell rather than a specific reference, so something like i = activecell.Value? — Dibstar, Feb 02 '12 at 15:50

Excel 2007 VBA copy rows x times based on text filter

2 Answers2

Linked