Excel 2007 VBA根据文本过滤器复制行x次答案

【问题标题】：Excel 2007 VBA copy rows x times based on text filterExcel 2007 VBA根据文本过滤器复制行x次
【发布时间】：2012-02-01 16:05:36
【问题描述】：

我是 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 年 3 月之前以一个月的增量添加所有行。这意味着从 2012 年 4 月到 2013 年 3 月添加 12 行，包括名称、值和频率保持不变。

对于史蒂夫，我想在 2013 年 3 月添加一行对于 Dave，我想添加 3 行（每三个月一个）

如果第一个日期改为 2012 年 4 月 1 日，频率为每年一次。我不想补充任何内容，因为 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

提前致谢！

【问题讨论】：

不是每三个月每季度一次吗？
这对我来说就像一场噩梦，你需要的代码并不难，但是……可读性、实用性、布局和维护都是有问题的。考虑更改您的设计，可能会分布在多张工作表上，并使用一张原始数据表格并在另一张表格上展示。
@Wilhelm - 绝对（在漫长的一天结束时写了这个！）
@Reafidy - 也许最简单的实现是拥有一个仅对活动单元格执行此操作的函数，我们正在查看底部的数据？

标签： vba excel copy excel-2007

【解决方案1】：

达文

Wilhelm，问了一个有效的问题。我仍在继续并假设通过说“季度”你只想增加 4 个月。

我还假设（我想我在这一点上是正确的）您希望继续增加日期直到它们小于 2013 年 3 月 1 日（无论是否它是每年、每季度或每月）

请尝试此代码。我相信它可以做得更完美。 ;)

久经考验

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

快照

【讨论】：

谢谢你 - 季度值是我的错误，但我认为考虑到结构，它应该不会太难处理！我已经对其进行了测试，它确实有效，我只需要弄清楚它是如何发挥它的魔力的！ :)
是否可以询问如何使用此功能也/而不是仅对最后一行数据执行此操作并粘贴到下方（因此基于示例，使用 A5 作为活动单元格并通过A6 和 A7 中的 2 行）？谢谢！
Davin，这是我在单元格“For i = 2 To LastRow”中循环的地方，您始终可以将其设置为 A5。我使用 ws1 作为输出的第二张纸。您可以将其定向到当前工作表:)
抱歉这里的无知，但如果我希望 A5 成为活动单元格而不是特定参考，并粘贴下面的行（因此一次只取一个案例），我将如何修改“For i=2 to lastrow”位？谢谢:)
我可以给你答案，但我希望你先了解代码:)。 “For i=2 to lastrow”从单元格 A2 循环到 A(Lastrow)。所以如果我只是想和 A5 交互那我们应该怎么做呢？我们应该如何编写它以使其仅针对单元格 A5？

【解决方案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

Origin 是包含原始数据的工作表，Destiny 是保存扩展数据的工作表。 OriginRow 是 Origin 工作表中正在分析的当前行（从第一行开始）。 OriginColumn 是在 Destiny 工作表中写入的当前行（从第一行开始）。 SourceDate 将被添加若干个月，直到达到 MaxDate。

【讨论】：

谢谢你 - 请原谅我的无知，但我说我的原始单元格只是活动单元格，我想将数据粘贴到它正下方的行中 - 即对于我的 Dave 示例（季度），如果活动单元格是 A10，我想在下面粘贴另外三行数据吗？
不要丢失您的输入数据。以后更正可能会更困难。无论如何，输出工作表都会包含您的原始数据。