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。