Excel VBAコピー貼り付けエラー

Question

行全体をコピーしてExcelの別のワークシートに貼り付けるVBAマクロを作成したかったのですが、

私のワークシートは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 

Answer 1

（唯一の1行目に値が貼り付けられている）「期限切れ」私が理解しているように、あなたの日付基準が一致する場合には、行の最初の4列を別のシートにコピーしようとしています。以下のコードは、トリックを行う必要がありますが、後でハイライトを削除すると、セルを強調表示しません。このコードを毎日実行したい場合は、毎日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