[VBA] Μεγάλη καθυστέρηση εκτέλεσης macro

[Βασίλης Καραχάλιος]

Καλημέρα,

Σε αρχείο με περιπου 2000 γραμμές θέλω να διαγράψω γραμμές οι οποιες σε μία στήλη δεν περιέχουν την τιμή που θέλω...

    Sheets("Sheet1 (4)").Select
      
    I = Cells(Rows.Count, "D").End(xlUp).Row
    'Range("d" & (I + 1)) = "last row"
    
        For K = I To 1 Step -1
        If Range("D" & K) <> "Bounced and cleared" Then
            Range("D" & K).EntireRow.Delete
          
        End If
    
    Next K

Χρησιμοποίησα λοιπόν τον παραπάνω κώδικα..
Παρατήρησα όμως οτι καθυστερεί αρκετά ώστε να μου δώσει το επιθυμητό αποτέλεσμα
Μήπως υπάρχει πιό σύντομος τρόπος ;
Μπορείτε να μου δώσετε κατευθύνσεις να το ψάξω ;

[Spirosgr]

Καλημέρα
Δεν βλέπω μεγάλη καθυστέρηση.
Δοκίμασε το παρακάτω:

Με τον κώδικα αυτόν:

Sub postNumb()
    Dim i As Long
    For i = 1 To 3000
        Cells(i, 4).Value = i
    Next i
End Sub

βάζουμε στα γρήγορα για δοκιμές σε 3000 γραμμές, d στήλη αριθμούς από 1 - 3000

και με αυτόν:

Sub test()
    Dim LastRow As Long, i As Long
    LastRow = Cells(Rows.Count, 4).End(xlUp).Row
    For i = LastRow To 1 Step -1
        If Cells(i, 4) < 1000 Then
            Cells(i, 4).EntireRow.Delete
        End If
    Next i
End Sub

διαγράφουμε τα < από 1000

χρόνος εκτέλεσης 0,11 sec

[Βασίλης Καραχάλιος]

καλημέρα Σπύρο,

έκανα λάθος ειναι περιπου 12000 οι γραμμες
δοκιμαζω αυτά που μου έγραψες και ενημερωνω

Ευχαριστώ, :)

[Βασίλης Καραχάλιος]

παλι έχω καθυστέρηση πάνω από πέντε λεπτά σίγουρα ... :(


το laptop ειναι Hp 6475b,είναι ΟΚ σχετικά.

[Spirosgr]

Δοκίμασα με 12000 γραμμές
Ίδιος κώδικας
Ζητούμενο: διέγραψε τιμές < 5000
Χρόνος 0,34 sec

[Βασίλης Καραχάλιος]

Χμ. Κάτι δεν γίνεται σωστά στο δικό μου....
αυτό τον κώδικα χρησιμοποιώ
και χρησιμοποιώ αλλο αρχείο με μόνο μία στήλη .....

Sub DeleteRows()
'
' deleterowsuptodown Macro
'
Dim LastRowPort As Long, a As Long
    LastRowPort = Cells(Rows.Count, 1).End(xlUp).Row
    For a = LastRowPort To 1 Step -1
        If a > 1 And Cells(a, 1) <> "" Then
            Cells(a, 1).EntireRow.Delete
        End If
    Next a

Selection.AutoFilter


End Sub

[Spirosgr]

Αυτό είναι «λίγο» διαφορετικό από αυτό που ζήτησες στην αρχή
Λοιπόν...

Sub DeleteRows()
    On Error Resume Next
    Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants, xlNumbers).EntireRow.Delete
End Sub

Αυτό διαγράφει στην Α στήλη από κελί 2 μέχρι πάτο σταθερές που είναι αριθμοί
Αν θέλεις άλλο είδος άλλαξε αυτό
xlCellTypeConstants

και αυτό
xlNumbers