VBA Kısmında Saat Buldurma

[Berke77]

Herkese merhaba,

Bir excel tablom var K sütununda süreler yer alıyor ve ben burada dolu hücreler boyunca 15 dakika altında olan süreleri sildirmek istiyorum. Benzer işlemleri çok defa yaptım ancak saat formatında olmadı bir türlü. Yardımcı olabilir misiniz? Formatım (hh:mm)

 

[askm]

Aşağıdaki şekilde deneyin.

Sub ASKM_Dakika_Sil()
Dim sonsat As Long
Dim zaman1, zaman2 As Date
sonsat = Range("K" & Rows.Count).End(xlUp).Row
zaman1 = Format("00:20:00", "hh:mm")
For i = sonsat To 1 Step -1
zaman2 = Format(Cells(i, "k"), "hh:mm")
If zaman2 < zaman1 Then
       Cells(i, "k").Delete
End If
Next
MsgBox "İşlem tamam...", vbInformation, "ASKM"
End Sub

 

[Berke77]

Denedim olmadı hocam malesef. Formatı okumuyo nedense

 

[askm]

Örnek dosyanızı siteye ya da http://www.dosyaupload.com/ buraya eklerseniz. Bakalım.

 

[Berke77]

Bilgi gizliliğinden dolayı diğer hücrelerdeki verileri sildim.
http://www.dosyaupload.com/hj21

 

[alicimri]

Aşağıdaki gibi deneyin Sn ASKM'ın kodlarını biraz değiştirdim.

Sub ASKM_Dakika_Sil()
Dim sonsat As Long
sonsat = Range("K" & Rows.Count).End(xlUp).Row
For i = sonsat To 1 Step -1
If  Cells(i, "k") < 1.04166666666667E-02 Then
       Cells(i, "k").Delete
End If
Next
MsgBox "İşlem tamam...", vbInformation, "ASKM"
End Sub

 

[askm]

Tüm satırı silmek istiyorsunuz sanırım.

Sub ASKM_Dakika_Sil()
Dim sonsat As Long
Dim zaman1, zaman2 As Date
sonsat = Range("K" & Rows.Count).End(xlUp).Row
zaman1 = Format("00:20:00", "hh:mm")
For i = sonsat To 2 Step -1
zaman2 = Format(Cells(i, "k"), "hh:mm")
If zaman2 < zaman1 Then
       Rows(i).Delete
End If
Next
MsgBox "İşlem tamam...", vbInformation, "ASKM"
End Sub

 

[alicimri]

Döngü ile uzun sürüyor aşağıdaki gibi dnreyin

Sub Makro2()

sonsat = Range("K" & Rows.Count).End(xlUp).Row
    ActiveSheet.Range("K1:K" & sonsat).AutoFilter Field:=1, Criteria1:="<00:15" _
        , Operator:=xlAnd
    ActiveSheet.Range("K2:K" & sonsat).ClearContents
 ActiveSheet.Range("K1:K" & sonsat).AutoFilter
End Sub

 

[askm]

Aşağıdaki şekilde denedim. İşlem 1 sn sürdü.

Sub ASKM_Dakika_Sil()
Dim sonsat As Long
Dim baslangic, bitis As Date

Dim zaman1, zaman2 As Date
Application.ScreenUpdating = False
baslangic = Time
On Error Resume Next
sonsat = Range("K" & Rows.Count).End(xlUp).Row
zaman1 = Format("00:20:00", "hh:mm")
For i = sonsat To 2 Step -1
zaman2 = Format(Cells(i, "k"), "hh:mm")
If zaman2 < zaman1 Then
       Rows(i).Delete
End If
Next
bitis = Time
Application.ScreenUpdating = True
MsgBox Format(bitis - baslangic, "hh:mm:ss") & " Sürede İşlem Tamamlandı" & vbLf & Application.UserName, _
vbInformation, "ASKM"
End Sub

 

[Berke77]

Teşekkürler oldu