Bu makroyu hızlandırmak

[Alpay Black]

Arkadaslar asagıdakı makroyu burdan bır arkadaşımız hazırladı.
sagolsun fakat 2000 adet satır verı de agır çalışıyor nasıl hızlandırırız yardımcı olurmusunz


Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A2:T2")) Is Nothing Then Exit Sub
BUL
Range(Target.Address).Select
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("A2:T2")) Is Nothing Then Exit Sub
'If Target.Column <> 2 Then Exit Sub
'If Target.Row > 1 Or Target.Row < 9 Then Exit Sub
BUL
End Sub


Private Sub BUL()

Application.ScreenUpdating = False
yer = ActiveSheet.Name
Set sh = Sheets(yer)
Rows("2:1000").EntireRow.Hidden = False

For i = 2 To [a65536].End(3).Row + 1
aranan1 = ""
aranan2 = ""
For n = 1 To WorksheetFunction.CountA(Columns("A")) + 1

If n = 20 Then
aranan1 = aranan1 & Mid(Format(Cells(i, 20).Value), 1, Len(Cells(2, 20).Value))
Else
aranan1 = aranan1 & UCase(Mid(sh.Cells(i, n).Value, 1, Len(Cells(2, n).Value)))
End If

aranan2 = aranan2 & UCase(Cells(2, n).Value)

Next n
aranan1 = UCase(Replace(Replace(aranan1, "I", "İ"), "i", "I"))
aranan2 = UCase(Replace(Replace(aranan2, "I", "İ"), "i", "I"))

If aranan1 <> aranan2 Then
Rows(i).EntireRow.Hidden = True
End If
Next i

Application.ScreenUpdating = True



End Sub

yardım ıcın teşekkür ederım

 

[catalinastrap]

şu şekilde bir deneyin

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, Range("A2:T2")) Is Nothing Then Exit Sub
BUL
Range(Target.Address).Select
End Sub
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("A2:T2")) Is Nothing Then Exit Sub
'If Target.Column <> 2 Then Exit Sub
'If Target.Row > 1 Or Target.Row < 9 Then Exit Sub
BUL
End Sub


Private Sub BUL()

Application.ScreenUpdating = False
yer = ActiveSheet.Name
Set sh = Sheets(yer)
Rows("2:1000").EntireRow.Hidden = False

For i = 2 To [a65536].End(3).Row + 1
aranan1 = ""
aranan2 = ""
For n = 1 To WorksheetFunction.CountA(Columns("A")) + 1

If n = 20 Then
aranan1 = aranan1 & Mid(Format(Cells(i, 20).Value), 1, Len(Cells(2, 20).Value))
Else
aranan1 = aranan1 & UCase(Mid(sh.Cells(i, n).Value, 1, Len(Cells(2, n).Value)))
End If

aranan2 = aranan2 & UCase(Cells(2, n).Value)

Next n
aranan1 = UCase(Replace(Replace(aranan1, "I", "İ"), "i", "I"))
aranan2 = UCase(Replace(Replace(aranan2, "I", "İ"), "i", "I"))

If aranan1 <> aranan2 Then
Rows(i).EntireRow.Hidden = True
End If
Next i

Application.ScreenUpdating = True
Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic


End Sub

 

[Alpay Black]

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, Range("A2:T2")) Is Nothing Then Exit Sub
BUL
Range(Target.Address).Select
End Sub
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("A2:T2")) Is Nothing Then Exit Sub
'If Target.Column <> 2 Then Exit Sub
'If Target.Row > 1 Or Target.Row < 9 Then Exit Sub
BUL
End Sub


Private Sub BUL()

Application.ScreenUpdating = False
yer = ActiveSheet.Name
Set sh = Sheets(yer)
Rows("2:1000").EntireRow.Hidden = False

For i = 2 To [a65536].End(3).Row + 1
aranan1 = ""
aranan2 = ""
For n = 1 To WorksheetFunction.CountA(Columns("A")) + 1

If n = 20 Then
aranan1 = aranan1 & Mid(Format(Cells(i, 20).Value), 1, Len(Cells(2, 20).Value))
Else
aranan1 = aranan1 & UCase(Mid(sh.Cells(i, n).Value, 1, Len(Cells(2, n).Value)))
End If

aranan2 = aranan2 & UCase(Cells(2, n).Value)

Next n
aranan1 = UCase(Replace(Replace(aranan1, "I", "İ"), "i", "I"))
aranan2 = UCase(Replace(Replace(aranan2, "I", "İ"), "i", "I"))

If aranan1 <> aranan2 Then
Rows(i).EntireRow.Hidden = True
End If
Next i

Application.ScreenUpdating = True
Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic


End Sub

Hocam teşkkur ederim ama hala aynı agır çalışıyor ve ben bunu kendı makınemde denıyom bırde agda dusun ne kadar agır calısacagını

 

[catalinastrap]

Dosya

Merhaba,
Dosyanı eklermisin örnek üzerinden gidersek daha sağlıklı olacak galiba

 

[Alpay Black]

Dosya ektedır

 

[Alpay Black]

merhaba,
dosyanı eklermisin örnek üzerinden gidersek daha sağlıklı olacak galiba

hocam dosyayı ekledım