我想创建一个VBA宏,它将复制整行并将其粘贴到Excel中的另一个工作表中 .
我的工作表从A列到D,大约有700行 . D列是一些随机日期 .
问题:我必须确定过期日期(并且过期日期始终为'今天')并复制到名为“过期”的新工作表 . 我所做的是找到日期,突出显示,复制,粘贴,然后清除突出显示,但我在工作表中粘贴名为“过期”的单元格时遇到问题(仅第一行粘贴了值)
Sub ExtractExpired()
Application.ScreenUpdating = False
Sheets("Sheet1").Select
Range("d1").Select
Selection.Offset(1, 0).Select
x = Date
Z = vbBlue
Do Until Selection.Offset(0, -2).Value = ""
If Selection.Offset(0, 0).Value < x Then 'And Selection.Offset(0, 0).Value <= x Then
Range(Selection.Offset(0, -3), Selection.Offset(0, 0)).Interior.Color = Z 'And Range(Selection.Offset(0, -3), Selection.Offset(0, 0)).Font.Color = vbBlue
'If Selection.Offset(0, 0).Interior.Color = Z Then
'r = Range("a1").End(xlDown).Row
'countexpired = 2
'For q = r To 2 Step -1
'Range(Cells(q, "a"), Cells(q, "d")).Copy
'If Selection.Offset(0, 0).Interior.Color = Z Then
'Sheets("Expired").Select
'Cells(countexpired, "A").Select
'ActiveSheet.Paste
'countexpired = countexpired + 1
'Sheets("Sheet1").Select
'End If
'Next
'Call sortItem
'Range(Selection.Offset(0, -3), Selection.Offset(0, 0)).Copy (Worksheets("Expired").Range("d1"))
'ActiveCell.EntireRow.Copy (Worksheets("Expired").Range("d1"))
'End If
End If
Selection.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
End Sub
1 回答
据我了解,如果您的日期条件匹配,您尝试将行的前四列复制到另一张表 . 下面的代码应该可以解决问题,但是它不会突出显示单元格,因为无论如何您都会删除高亮显示 . 如果您想每天运行此代码,则需要每天调整c值,使用最新的行 .