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 

而我想在這種情況下，做的是莎拉在一個月的增量中的所有行添加，直至2013年3月這意味着將在12行，從2012年4月至2013年3月，名稱，價值和頻率保持不變。

史蒂夫·我想在一行中添加對2013年3月 對於戴夫，我想在3行（一個每三個月）

添加如果第一次約會要成爲第一個2012年4月，而不是，和頻率年度。我想在沒有增加任何新的有2013年3月

對於上述樣品之前沒有其他日期的輸出是：

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

達文

威廉，問一個有效的問題。我仍在繼續前進，並假設說'季度'只需要增加4個月。

我也假設（我想我是正確的就這一個，雖然）你想保持遞增日期到時候他們是小於2013年3月1日（無關緊要的事實，無論是年度， QUARTERLY或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。