makro hızlandırma yardım

[elcindmr]

merhaba ;
aşağıdaki makro kodunu 264129 satır için çalıştırdığımda çok ciddi yavaşlama oluyor. hatta 2 saat bekledim ancak cevap vermiyor excell. hızlandırma için yardımcı olur musunuz ?


Sub B1C1D1()
Dim a As String
a = Sayfa1.Range("C1").Value
say = Sayfa1.Range("A264129").End(xlUp).Row

Dim conn As Object, rs As Object
Set conn = CreateObject("AdoDb.Connection")
Set rs = CreateObject("AdoDb.Recordset")
If Dir(ThisWorkbook.Path & "\" & a & ".xlsx") = "" Then
MsgBox "Belirttiğiniz Dosya Bulunamadı", vbCritical
Exit Sub
Else
conn.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.Path & "\" & a & ".xlsx" & ";extended properties=""excel 12.0;hdr=yes"""
For i = 2 To say
rs.Open "Select * from [Sayfa1$] where tn =" & CDbl(Range("a" & i)) & ";", conn, 1, 3
'rs.movefirst
Range("B" & i).CopyFromRecordset rs
rs.Close
Next
conn.Close
Set rs = Nothing
Set conn = Nothing
End If
End Sub

Sub E1F1G1()
Dim a As String
a = Sayfa1.Range("F1").Value
say = Sayfa1.Range("A264129").End(xlUp).Row

Dim conn As Object, rs As Object
Set conn = CreateObject("AdoDb.Connection")
Set rs = CreateObject("AdoDb.Recordset")
If Dir(ThisWorkbook.Path & "\" & a & ".xlsx") = "" Then
MsgBox "Belirtilen Dosya Mevcut Değil !", vbCritical
Exit Sub
Else
conn.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.Path & "\" & a & ".xlsx" & ";extended properties=""excel 12.0;hdr=yes"""
For i = 2 To say
rs.Open "Select * from [Sayfa1$] where tn =" & CDbl(Range("a" & i)) & ";", conn, 1, 3

Range("E" & i).CopyFromRecordset rs
rs.Close
Next
conn.Close
Set rs = Nothing
Set conn = Nothing
End If
End Sub
Sub H1I1J1()
Dim a As String
a = Sayfa1.Range("J1").Value
say = Sayfa1.Range("264129").End(xlUp).Row

Dim conn As Object, rs As Object
Set conn = CreateObject("AdoDb.Connection")
Set rs = CreateObject("AdoDb.Recordset")
If Dir(ThisWorkbook.Path & "\" & a & ".xlsx") = "" Then
MsgBox "Belirtilen Dosya Mevcut Değil !", vbCritical
Exit Sub
Else
conn.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.Path & "\" & a & ".xlsx" & ";extended properties=""excel 12.0;hdr=yes"""
For i = 2 To say
rs.Open "Select * from [Sayfa1$] where tn =" & CDbl(Range("a" & i)) & ";", conn, 1, 3

Range("H" & i).CopyFromRecordset rs
rs.Close
Next
conn.Close
Set rs = Nothing
Set conn = Nothing
End If
End Sub


Private Sub CommandButton1_Click()

B1C1D1
E1F1G1
H1I1J1
End Sub