Kodlama Hakkında Yardım ve Öneri

[hilmitaranci]

Merhabalar,

Aşağıda içeriği 0 olan satırları silmek için kullandığım kodlama mevcut.

Sheets("sql").Select
For cc = [E1].End(xlDown).Row To 2 Step -1
If Cells(cc, 22).Value = "0" And s2.Cells(cc, 23) < 0.01 Then
Rows(cc).Delete
End If
Next cc

bu kod ile varmak istediğim sonuca problemsiz ulaşıyorum.

Benim size danışmak istediğim

Bu kodu çalıştırınca satırların silineceği sayfaya gidiyor ve satırlar silinirken ekrandan izliyorum.
Satır sayısı 20 bine yakın olduğu için oldukça uzun süren bir işlem oluyor.

Bu kod daha hızlı çalışabilecek bir hale gelir mi?

 

[Ziynettin]

Merhaba,

Sorunuza ait örnek dosya ekleyebilir misiz.

 

[hilmitaranci]

Merhaba,

Sorunuza ait örnek dosya ekleyebilir misiz.

Örnek dosyayı ekledim.

http://www.dosya.tc/server7/xvghrh/makrolu_butce_hammaddee.xls.htm

 

[Ziynettin]

Eklediğiniz link de doysa yüklü değil.

 

[hilmitaranci]

Eklediğiniz link de doysa yüklü değil.

Dosyayı tekrardan ekldim.

http://s8.dosya.tc/server2/6cstpu/makrolu_butce_hammaddee.xls.html

 

[Ziynettin]

Kodu module ekleyip sgl sayfasında düğmeye atayınız.

Sub Sil()
Dim a(), b(), S1 As Worksheet, T As Double
Dim X As Long, Y As Integer, Say As Long, Son As Long
Dim Deg_1 As Double, Deg_2 As Double

T = Timer
Application.ScreenUpdating = False
Set S1 = Sheets("sql")
Deg_1 = "0.00"
Deg_2 = "0.01"
Son = S1.Cells(Rows.Count, 1).End(3).Row
a = S1.Range("A2:W" & Son).Value

ReDim b(1 To UBound(a), 1 To UBound(a, 2))
Say = 0
For X = 1 To UBound(a)
    If a(X, 22) <> Deg_1 Or a(X, 23) >= Deg_2 Then
        Say = Say + 1
            For Y = 1 To UBound(a, 2)
                b(Say, Y) = a(X, Y)
            Next Y
    End If
Next X
If Say > 0 Then
S1.Range("A2:W" & Rows.Count).ClearContents
S1.Range("A2").Resize(Say, UBound(a, 2)) = b
End If
Application.ScreenUpdating = True
MsgBox "İşlem tamam." & vbLf & vbLf & "Süre : " & Format(Timer - T, "0.00"), vbInformation
End Sub

 

[hilmitaranci]

Kodu module ekleyip sgl sayfasında düğmeye atayınız.

Sub Sil()
Dim a(), b(), S1 As Worksheet, T As Double
Dim X As Long, Y As Integer, Say As Long, Son As Long
Dim Deg_1 As Double, Deg_2 As Double

T = Timer
Application.ScreenUpdating = False
Set S1 = Sheets("sql")
Deg_1 = "0.00"
Deg_2 = "0.01"
Son = S1.Cells(Rows.Count, 1).End(3).Row
a = S1.Range("A2:W" & Son).Value

ReDim b(1 To UBound(a), 1 To UBound(a, 2))
Say = 0
For X = 1 To UBound(a)
    If a(X, 22) <> Deg_1 Or a(X, 23) >= Deg_2 Then
        Say = Say + 1
            For Y = 1 To UBound(a, 2)
                b(Say, Y) = a(X, Y)
            Next Y
    End If
Next X
If Say > 0 Then
S1.Range("A2:W" & Rows.Count).ClearContents
S1.Range("A2").Resize(Say, UBound(a, 2)) = b
End If
Application.ScreenUpdating = True
MsgBox "İşlem tamam." & vbLf & vbLf & "Süre : " & Format(Timer - T, "0.00"), vbInformation
End Sub

Hocam ellerine kollarına sağlık, benim makroyu araba gibi hızlı zannederken , kaplumbağa gibi olduğunu gördüm .

Sayende kaç dakikalık işin 10 -15 sn. indirdi.

Çok teşekkür ederim.