改良したものを記載しております

Sub CopyValues()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lastRow As Long
    Dim i As Long
    
    Set ws1 = ThisWorkbook.Sheets("欲しいリスト")
    Set ws2 = ThisWorkbook.Sheets("×××")
    Set ws3 = ThisWorkbook.Sheets("YYY")
    
    最終行 = ws1.Cells(ws1.Rows.Count, "B").End(xlUp).Row
    
    For i = 2 To 最終行
        If ws1.Cells(i, "B").Value = "×××" Then
            
            '日付
            ws2.Range("B2").Value = ws1.Cells(i, "A").Value
            '指日
            ws2.Range("D2") = ws1.Range("H1").Value
'            '印刷
'            ws2.PrintOut
'
'            '値をクリア
'            ws2.Range("B2").Value = ""
'            ws2.Range("C2").Value = ""
            
            
            
            
        ElseIf ws1.Cells(i, "B").Value = "YYY" Then
        
            
            '日付
            ws3.Range("B2").Value = ws1.Cells(i, "A").Value
            '指日
            ws1.Range("H1").Copy Destination:=ws3.Range("D2")
'            '印刷
'            ws3.PrintOut
'
'            '値をクリア
'            ws3.Range("B2").Value = ""
'            ws3.Range("C2").Value = ""
            
        End If
    Next i
    
End Sub