Excel 2007 VBA копирует строки x раз на основе текстового фильтра

Question

Я новичок в VBA и могу обернуть голову вокруг наиболее эффективного способа сделать это - то, что я ищу, - это способ скопировать мои данные в строки под активной ячейкой на основе частоты.

Образец данных, как это:

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 

И то, что я хотел бы сделать в этом случае для Sarah добавить во всех строках с шагом один месяц до марта 2013 года Это будет означать добавление в 12 строк, с апреля 2012 года по март 2013 года, с постоянным значением, значением и частотой.

Для Стива я хотел бы добавить в один ряд на март 2013 Для Дэйва я хотел бы добавить в 3 ряда (один раз в три месяца)

Если первая дата должны были быть 1 апреля 2012 вместо этого, и частота годовых. Я хотел бы добавить в ничто, как не существует другая дата до марта 2013 года

Для вышеуказанного образца на выходе будет:

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 

Заранее спасибо!

Answer 1

Davin

Wilhelm, заданный вопрос. Я все еще продолжаю и полагаю, что, говоря «ежеквартально», вы просто хотите добавить 4 месяца.

Я также предполагаю, что (я думаю, я правильно на этом, хотя) вы хотите сохранить на увеличивающиеся даты до времени они меньше, чем на 1 марта 2013 года (несущественным о том, является ли это ЕЖЕГОДНЫЙ, QUARTTERLY или MONTHLY)

Пожалуйста, попробуйте этот код. Я уверен, что это можно сделать более совершенным. ;)

испытанный

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 

Снимок

Answer 2

Вам нужна функция, которая переводит частотный текст на несколько месяцев (назовем его MonthFreq, возвращающим целое число).

Это будет делать то, что вы хотите:

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 

происхождение является таблицей с исходными данными, Судьба рабочего листа, где будет сохранено расширенным данные. OriginRow - текущая строка, анализируемая на листе Origin (начинается с первой строки). OriginColumn - это текущая строка, написанная на листе Destiny (начинается с первой строки). SourceDate будет добавлено некоторое количество месяцев, пока не достигнет MaxDate.