Question

我想创建一个VBA宏，它将复制整行并将其粘贴到Excel中的另一个工作表中。

我的工作表从A列到D，大约有700行。 D列是一些随机日期。

问题：我必须确定过期日期（过期日期始终为＆＃39;今天＆＃39;）并复制到名为“已过期”的新工作表中。我所做的是找到日期，突出显示，复制，粘贴，然后清除突出显示，但我无法粘贴名为＆＃39; Expired＆＃39;的工作表中的单元格。（只有第一行粘贴了值）

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

Answer 1

据我了解，如果您的日期条件匹配，您正尝试将行的前四列复制到另一张表。下面的代码应该可以解决问题，但它不会突出显示单元格，因为无论如何您都会删除高亮显示。如果您想每天运行此代码，则需要每天调整c值，使用最新的行。

Sub CopyPaste()
Dim ws1 as worksheet, ws2 as worksheet
Dim i as integer, j as integer
Dim x as Date
x = Date
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Expired")
i = 2 ' First row used in Sheet 1
c = 2 ' First row used in Expired Sheet

Do until IsEmpty(ws1.Cells(i,4))
   if ws1.Cells(i,4) = x Then
       ws1.Range(ws1.Cells(i,1),ws1.Cells(i,4)).copy Destination:=ws2.Range(w2.Cells(c,1),w2.Cells(c,4))
       c = c +1 ' move to next row in expired sheet when value has been copied
   end if
   i = i +1 ' move to next row in Sheet1 regardless if value has been copied or not
Loop
End Sub

Excel VBA复制粘贴错误

1 个答案: