Excel 2007 VBA复制行x次基于文本过滤器 [英] Excel 2007 VBA copy rows x times based on text filter
问题描述
我是VBA的新手，可以用最有效的方式来做这件事 - 我正在寻找的是根据频率将我的数据复制到活动单元格以下的行。 / p>
示例数据如下：
名称值频率日期
Steve 10 Annual 01/03/2012
Dave 25季度01/03/2012
Sarah 10月01/03/2012
Gavin 27季度01/04/2012
在这种情况下，我想做的是为所有行添加一个月增量，直到2013年3月。这意味着从2012年4月到2013年3月，添加12行，其名称，值和频率保持不变。
对于Steve，我想添加一行2013年3月
对于Dave我想添加3行（每三个月一个）
如果第一个日期是2012年4月1日，和频率年。由于在2013年3月之前没有其他日期。
对于上面的示例，输出结果为：
名称价值频率日期
Steve 10年度01/03/2012
Steve 10年度01/03/2013
Dave 25季度01/03/2012
Dave 25季度01/07/2012
Dave 25季度01/11/2012
Dave 25季度01/03/2013
Sarah 10 Monthly 01 / 03/2012
Sarah 10月01/04/2012
Sarah 10月01/05/2012
Sarah 10月01/06/2012
Sarah 10月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
提前感谢！
Davin
Wilhelm，问一个有效的问题。我还在继续，假设通过说季度你只想添加4个月。
我也假设（我猜我是正确的在这一个虽然），你想继续增加日期，直到他们不到2013年3月1日（无论是年度，季度还是每月的事实）
请尝试此代码。我相信它可以做得更完美。 ;）
TRIED AND TESTED
选项显式
Sub Sample（）
Dim ws作为工作表，ws1作为工作表
Dim i As Long，j As Long，LastRow As Long
Dim boolOnce As布尔
Dim dt作为日期
出现错误GoTo Whoa
Application.ScreenUpdating = False
'~~>输入表
设置ws =表格（Sheet1）
'~~>输出表
设置ws1 =表格（Sheet2）
ws1.Cells.ClearContents
'~~>从输入表获取最后一行
LastRow = ws.Range（A& ws.Rows.Count）.End（xlUp）.Row
boolOnce = True
'~~>循环通过输入表中列A中的单元格
对于i = 2到LastRow
j = ws1.Range（A& ws1.Rows.Count）.End（xlUp）.Row + 1
选择案例UCASE（ws.Range（C& i）.Value）
案例ANNUAL
dt = DateAdd（yyyy，1，ws.Range D& i）.Value）
'〜〜>检查日期是否小于2013年3月1日
如果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。范围（B& i）.Value
ws1.Range（C&：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）
如果
结束QUARTERLY
dt = DateAdd ，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
如果boolOnce = True然后
ws1.Range（D& j）.Value = DateAdd ，-4，dt）
boolOnce = False
Else
ws1.Range（D& j）.Value = dt
如果
dt = DateAdd （M，4，ws1.Range（D& j）.Value）
j = j + 1
Loop
boolOnce = True
案例MONTHLY
dt = DateAdd（M，1，ws.Range（D& i）.Value）
Do While dt <=＃3/1/2013＃
ws1。范围（A& j）.Value = ws.Range（A& i）.Value
ws1.Range（B& j）.Value = ws.Range & i）.Value
ws1.Range（C& j）.Value = ws.Range（C& i）.Value
如果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
结束选择
下一页i
LetsContinue：
Application.ScreenUpdating = True
退出子
Whoa：
MsgBox Err .Description
Resume LetsContinue
End Sub
快照
>
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!
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
这篇关于Excel 2007 VBA复制行x次基于文本过滤器的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
