vba 根据条件“日期”值将一行数据从 sheet2 复制到 sheet1
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/6428607/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Copy a Row of Data based on a conditional 'Date' value from sheet2 to sheet1
提问by John Lauer
Developing using Excel 2007, but need to be compatible with 2003.
使用Excel 2007开发，但需要兼容2003。
Problem:
问题：
Workbook has two sheets. Sheet two contains data, columns A thru M. Column C is formatted for Date values. Not all rows contain a value in column C.
工作簿有两张纸。第二张表包含数据，列 A 到 M。列 C 的格式设置为日期值。并非所有行都包含 C 列中的值。
Sheet One has 3 'Option Buttons (form Control), labeled Contract date, Effective Date, and End Date. When contract date is selected, Need data on sheet two, column C (Date is contained here) to be queried with a conditional filter... If date < today's date + 14 days ... If true, copy column C thru M of that row to Sheet One beginning at cell C13. Continue until all data rows have been tested.
第一页有 3 个“选项按钮”（表单控件），标有“合同日期”、“生效日期”和“结束日期”。选择合同日期后，需要使用条件过滤器查询第二张表 C 列（此处包含日期）上的数据...如果日期 < 今天的日期 + 14 天...如果为真，复制 C 列到 M 列该行从单元格 C13 开始到工作表一。继续，直到所有数据行都经过测试。
If another 'Option Button' is selected, results from first query are replaced by results from second query.
如果选择了另一个“选项按钮”，则第一个查询的结果将替换为第二个查询的结果。
Here is the code I have been working on, but it won't work.
这是我一直在处理的代码，但它不起作用。
Sub OptionButton1_Click()
Application.ScreenUpdating = False
TEMPLATE_SHEET = "Data_Input"
Database_sheet = "Carrier"
myzerorange = "C" & ActiveWindow.RangeSelection.Row & ":" & "M" & ActiveWindow.RangeSelection.Row
mycompany = "C" & ActiveWindow.RangeSelection.Row
mydate = "D" & ActiveWindow.RangeSelection.Row
Database_sheet = ActiveSheet.Name
DATABASE_RECORDS = Sheets(Database_sheet).Range("C2:C1000") Count_Row = 13
If Range(mycompany) <> "" Then
If Range(mydate) <> "" Then
'Range(mydate) = contractdate If mydate < DateAdd("d", 14, "Today()") Then Range(myzerorange).Copy Sheets(TEMPLATE_SHEET).Select 'To identify the next blank row in the database sheet DATABASE_RECORDS = Sheets(TEMPLATE_SHEET).Range("C13:C1000") 'To identify the next blank row in the data_Input sheet For Each DBRECORD In DATABASE_RECORDS If DBRECORD <> "" Then Count_Row = Count_Row + 1 Next DBRECORD Sheets(TEMPLATE_SHEET).Range("C" & Count_Row).Select ActiveSheet.Paste 'Return to origin and check for another contract date Sheets(Database_sheet).Select Else End IfElse
End If
End If
Application.ScreenUpdating = True
End Sub
子 OptionButton1_Click()
Application.ScreenUpdating = False
TEMPLATE_SHEET = "数据_输入"
Database_sheet = "运营商"
myzerorange = "C" & ActiveWindow.RangeSelection.Row & ":" & "M" & ActiveWindow.RangeSelection.Row
mycompany = "C" & ActiveWindow.RangeSelection.Row
mydate = "D" & ActiveWindow.RangeSelection.Row
Database_sheet = ActiveSheet.Name
DATABASE_RECORDS = Sheets(Database_sheet).Range("C2:C1000") Count_Row = 13
If Range(mycompany) <> "" 然后
If Range(mydate) <> "" 然后
'Range(mydate) = contractdate If mydate < DateAdd("d", 14, "Today()") Then Range(myzerorange).Copy Sheets(TEMPLATE_SHEET).Select 'To identify the next blank row in the database sheet DATABASE_RECORDS = Sheets(TEMPLATE_SHEET).Range("C13:C1000") 'To identify the next blank row in the data_Input sheet For Each DBRECORD In DATABASE_RECORDS If DBRECORD <> "" Then Count_Row = Count_Row + 1 Next DBRECORD Sheets(TEMPLATE_SHEET).Range("C" & Count_Row).Select ActiveSheet.Paste 'Return to origin and check for another contract date Sheets(Database_sheet).Select Else End If别的
万一
万一
Application.ScreenUpdating = True
结束子
This revised code still doesn't work... not sure what is hanging this up...
这个修改后的代码仍然不起作用……不知道是什么挂了这个……
`Sub CopyRowConditional()
Application.ScreenUpdating = False
Srownumber = 2 'source sheet row number "Data_Input"
Trownumber = 13 'target sheet row number "Carrier"
Do
Srownumber = Srownumber + 1
Trownumber = Trownumber + 1
If Cells(Srownumber, 3).Value = "" Then Exit Do
If Cells(Srownumber, 4).Value < DateAdd("d", 14, "Today()") Then
For Column = 3 To 13 Sheets(template_sheet).Cells(Trownumber, Column).Value = >Sheets(Database_sheet).Cells(Srownumber, Column).Value Next Column'End If
End If
Loop
Application.ScreenUpdating = True
End Sub`
`子 CopyRowConditional()
Application.ScreenUpdating = False
Srownumber = 2 '源表行号“Data_Input”
Trownumber = 13 '目标表行号“载体”
做
Srownumber = Srownumber + 1
Trownumber = Trownumber + 1
If Cells(Srownumber, 3).Value = "" Then Exit Do
If Cells(Srownumber, 4).Value < DateAdd("d", 14, "Today()") Then
For Column = 3 To 13 Sheets(template_sheet).Cells(Trownumber, Column).Value = >Sheets(Database_sheet).Cells(Srownumber, Column).Value Next Column'万一
万一
环形
Application.ScreenUpdating = True
结束子`
回答by frenchie
This is what I have in mind for your problem. See the comments. You need to bind the button click to CopyRowConditional.
这就是我对你的问题的想法。看评论。您需要将按钮单击绑定到 CopyRowConditional。
Sub CopyRowConditional()
Do
i = i + 1
If Cells(i, 1).Value = "" Then Exit Do
' this is to exit the loop when you reach an empty row
If Cells(i, 1).Value = 10 Then ' this is where you put
' the condition that triggers the copy
' here I just put 10 as an example
TargetRow = 4 ' this is where you need to determine how
' you select the row that will receive the
' data you're copying in the Target sheet
' If you need to check for an empty row
' you can add a Do ... Loop statement
' that stops when the row is good
For j = 1 To 14 ' this is where you loop in to the
'column of the Source sheet
Sheets("Target").Cells(TargetRow, j).Value = Sheets("Source").Cells(i, j).Value
' this is the line that actually does the copying, cell by cell
' if you need to change the column index, just write .Cells(i, j+ n).value
' where n is any offeset you need
Next j
End If
Loop
End Sub
回答by frenchie
This seems pretty easy to do so my guess is that you don't know VBA very well. Like others have said, the site is not about building your app; it's about people who build apps helping other people who build apps.
这似乎很容易做到，所以我的猜测是您不太了解 VBA。正如其他人所说，该网站与构建您的应用程序无关；这是关于构建应用程序的人帮助其他构建应用程序的人。
As a pointer, you should be able to post your question on a gigs site and get your project done in a matter of hours. Try craigslist if you want to meet in person or elance or if you're ok with virtual.
作为指导，您应该能够在演出网站上发布您的问题并在几个小时内完成您的项目。如果您想亲自或 elance 见面，或者您对虚拟会议没问题，请尝试 craigslist。
Hope this helps.
希望这可以帮助。
