Çözüldü Ado ile veri çekiyorum hata veriyor.

Merhabalar, ado ile veriyi getiriyorum.fakat hata mesajı veriyor. arka planda dosya açık kalıyor. yardımcı olabilir misiniz?

kodlar şu şekildedir.
hata veren kod
'Worksheets("Ödenen").Range("A" & Worksheets("Ödenen").Range("A" & Rows.Count).End(3).Row + 1).CopyFromRecordset MyRs

Sub irsaliyebilgileri2()
Dim ifade As String, MyCn As Object, MyRs As Object
Dim Yol As String, Dosya As String, Sayfa As String, Aranan As String

'sonradan eklediğim
Dim rng As Range
Dim r As Range

Yol = ThisWorkbook.Path & "\" 'Ağdan almak istenirse ' Yol = "\\10.17.0.2\Muhasebe\HAM MADDE\HMK\Excel-Atık Kağıt\2021\"
Dosya = "dveri.xlsx"
Sayfa = "KDS-DÖKME"
Aranan = Range("F2")
Set rng = Sayfa2.Range("E4:E" & Sayfa2.Cells(Rows.Count, 5).End(xlUp).Row)
For Each r In rng
If r.Value = Aranan Then
MsgBox "Bu kayıt daha önce getirilmiş.", vbInformation + vbOKOnly, "İrsaliye"
Exit Sub
End If
Next r
Set MyCn = CreateObject("ADODB.Connection")
Set MyRs = CreateObject("ADODB.recordset")
MyCn.Provider = "Microsoft.ACE.OLEDB.12.0"
MyCn.Properties("Data Source") = Yol & Dosya
MyCn.Properties("Extended Properties") = "Excel 12.0 XML; HDR=Yes"
MyCn.Open

ifade = "Select * from [" & Sayfa & "$] Where [İRSALİYE NUMARASI] ='" & Aranan & "'"
MyRs.Open ifade, MyCn, 1, 1
If MyRs.RecordCount > 0 Then
Range("A" & Range("A" & Rows.Count).End(3).Row + 1).CopyFromRecordset MyRs
Worksheets("Ödenen").Range("A" & Worksheets("Ödenen").Range("A" & Rows.Count).End(3).Row + 1).CopyFromRecordset MyRs
End If
MyRs.Close
MyCn.Close
Set MyCn = Nothing: Set MyRs = Nothing

End Sub