Makronun Hızlı Çalışması İçin,

[akmes]

Merhaba;

Aşağıdaki makronun daha hızlı çalışması için ne yapılabilir yardımlarınızı rica ediyorum.

Sub Makro3()
Set Sh3 = Sheets("Detay_Aktarim")
Set Sh2 = Sheets("Detay")
Set Sh1 = Sheets("MS")
Sh2.Columns("A:F").ClearContents
Sh2.Columns("A:F").Interior.ColorIndex = xlNone
Sh2.Columns("A:F").Font.ColorIndex = 0
son = 2
satır = 0
For r = 2 To Sh3.Cells(Rows.Count, "a").End(3).Row
Sh2.Cells(son, 1) = Sh3.Cells(r, 1)
Sh2.Cells(son, 1).Interior.ColorIndex = 6
Sh2.Cells(son, 1).Font.ColorIndex = 3
sat = 0
Dim aranan As String
Dim Rng As Range
aranan = Sh3.Cells(r, 1)
If Trim(aranan) <> "" Then
With Sh1.Range("c:d")
Set Rng = .Find(What:=aranan, After:=.Cells(1), LookIn:=xlValues, lookat:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
If Not Rng Is Nothing Then
satır = Rng.Row
Else
MsgBox "Sonuç yok"
End If
End With
End If
If satır > 0 Then
For i = satır To 6 Step -1
If Sh1.Cells(i, "c").Value = aranan Or Sh1.Cells(i, "d").Value = aranan Then
sat = sat + 1
If sat <= 6 Then
Sh2.Cells(son + sat + 1, 1) = Sh1.Cells(i, 1)
Sh2.Cells(son + sat + 1, 2) = Sh1.Cells(i, 2)
Sh2.Cells(son + sat + 1, 3) = Sh1.Cells(i, 3)
Sh2.Cells(son + sat + 1, 4) = Sh1.Cells(i, 4)
Sh2.Cells(son + sat + 1, 5) = Sh1.Cells(i, 5)
Sh2.Cells(son + sat + 1, 6) = Sh1.Cells(i, 6)
Sh2.Cells(son + sat + 1, 7) = Sh1.Cells(i, 7)
Sh2.Cells(son + sat + 1, 8) = Sh1.Cells(i, 8)
End If
End If
Next
End If

son = son + 10
Next r
MsgBox "işlem tamam"
End Sub

 

[N.Ziya Hiçdurmaz]

Kod başına

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Kod sonuna koyarak deneyiniz.

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

 

[akmes]

Kod başına

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Kod sonuna koyarak deneyiniz.

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

Üstadım kod üzerinde şu şekilde
Sub Makro3()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = FalseSet
Sh3 = Sheets("Detay_Aktarim")
Set Sh2 = Sheets("Detay")
Set Sh1 = Sheets("MS")
Sh2.Columns("A:F").ClearContents
Sh2.Columns("A:F").Interior.ColorIndex = xlNone
Sh2.Columns("A:F").Font.ColorIndex = 0

Kod sonuna da şu şekilde

End If
Next
End If

son = son + 10
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Next r
MsgBox "işlem tamam"
End Sub

şeklinde yapıştırdım ama bir farklılık olmadı..

 

[N.Ziya Hiçdurmaz]

yanıt

İkincisini, Next r den sonrasına koyup deneyiniz.

 

[akmes]

İkincisini, Next r den sonrasına koyup deneyiniz.

Evet üstadım süper oldu.İnanın yarım saat bekliyordum şimdi 30 sn.
Çok teşekkür ederim.

 

[slmnkc]

çok teşekkürler