Makroyu hızlandırmak

[metin_0606]

Sub asciikod()
For i = 2 To Cells(Rows.Count, "A").End(3).Row
If Cells(i, "A") <> "" Then
Cells(i, "A") = Replace(Cells(i, "A"), Chr(13), "")
End If
Next
End Sub. Bu makroyu ASCII kodu 13 olan boşluğu siliyorum .Ancak 5000 satırlık veride çok yavaş çalışıyor. Kodu revize ederek hizlandirmamiz mümkünmü acaba

 

[Necdet]

Merhaba,
Aşağıdaki kodu dener misiniz?

Sub Makro1()

    Application.DisplayAlerts = False
    Columns("A:A").Replace What:=Chr(13), Replacement:="", LookAt:=xlPart
    Application.DisplayAlerts = True
    
End Sub

 

[metin_0606]

Merhaba,
Aşağıdaki kodu dener misiniz?

Sub Makro1()

    Application.DisplayAlerts = False
    Columns("A:A").Replace What:=Chr(13), Replacement:="", LookAt:=xlPart
    Application.DisplayAlerts = True
   
End Sub

Paylaştığım makrodan daha uzun sürede işlem yaptı Necdet bey

 

[Necdet]

Allah allah döngüden daha hızlı olmasını beklerdim, bende şaşırdım.
E o zaman yapacak bir şey yok.
Peki bul ve değiştiri makro değil Ctrl+H ile yapsanız hız açısından bir farklılık olur mu ki? denediniz mi?

 

[metin_0606]

Allah allah döngüden daha hızlı olmasını beklerdim, bende şaşırdım.
E o zaman yapacak bir şey yok.
Peki bul ve değiştiri makro değil Ctrl+H ile yapsanız hız açısından bir farklılık olur mu ki? denediniz mi?

O aradaki boşluk kısım boşluk değilde ASCII demişti forumdan Yusuf 44 bey o yüzden cntrl H işimi görmüyor Necdet bey

 

[genesis_vision]

Şu kodu deneyebilir misiniz?

Option Explicit

Sub asciikod()
Application.ScreenUpdating = False
Dim rng, c As Range
Dim irow As Long
irow = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range("a2:a" & irow)

For Each c In rng
If InStr(1, c, Chr(13)) Then
c = Application.Substitute(c, Chr(13), "")
End If
Next

Application.ScreenUpdating = True
End Sub

 

[genesis_vision]

Option Explicit

Sub asciikod()
Application.ScreenUpdating = False
Dim rng, c As Range
Dim irow As Long
irow = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range("a2:a" & irow)

For Each c In rng
    If InStr(1, c, Chr(13)) Then
        c = Application.Substitute(c, Chr(13), "")
    End If
Next

Application.ScreenUpdating = True
End Sub

 

[metin_0606]

Option Explicit

Sub asciikod()
Application.ScreenUpdating = False
Dim rng, c As Range
Dim irow As Long
irow = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range("a2:a" & irow)

For Each c In rng
    If InStr(1, c, Chr(13)) Then
        c = Application.Substitute(c, Chr(13), "")
    End If
Next

Application.ScreenUpdating = True
End Sub

Maalesef süre olarak değişen bir şey olmadi

 

[Necdet]

O aradaki boşluk kısım boşluk değilde ASCII demişti forumdan Yusuf 44 bey o yüzden cntrl H işimi görmüyor Necdet bey

Görür görürr.

ilgili karakteri koplayıp değiştirme yaptığınız yere yapıştırırsınız olur biter. Kopyalamayı Ctrl+Insert, yapıştırmayı Shift+Insert tuşları ile yaparsınız.
Çözüm her zaman vardır.

 

[metin_0606]

Görür görürr.

ilgili karakteri koplayıp değiştirme yaptığınız yere yapıştırırsınız olur biter. Kopyalamayı Ctrl+Insert, yapıştırmayı Shift+Insert tuşları ile yaparsınız.
Çözüm her zaman vardır.

Makrolu çözüm tercihimdir

 

[genesis_vision]

Maalesef süre olarak değişen bir şey olmadi

Ben 20.000 satırda denedim. Sadece 1 saniye sürüyor. Ya bilgisayarınızın performansı düşük ya da çalışma kitabında çok fazla formül vs kullanılmış.

 

[metin_0606]

Ben 20.000 satırda denedim. Sadece 1 saniye sürüyor. Ya bilgisayarınızın performansı düşük ya da çalışma kitabında çok fazla formül vs kullanılmış.
Ekli dosyayı görüntüle 213757

Örnek dosya paylaşıyorum

 

[genesis_vision]

Toplam 171.000 hücrenin her birinde chr(13) mevcut. Benim bilgisayarda 4 saniye sürüyor. Deneyiniz.

 

[Korhan Ayhan]

Alternatif;

Hız olarak avantaj sağlayabilir.

A sütunu için;

Option Explicit

Sub Ascii_Bosluk_Sil()
    Dim Veri As Variant, Son As Long, X As Long, Zaman As Double

    Zaman = Timer

    Son = Cells(Rows.Count, 1).End(3).Row
    Veri = Range("A3:A" & Son).Value

    ReDim Liste(1 To UBound(Veri), 1 To 1)

    For X = 1 To UBound(Veri)
        Liste(X, 1) = Trim(Replace(Veri(X, 1), Chr(13), ""))
    Next

    Range("A3").Resize(X - 1) = Liste

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

A-P sütun aralığı için;

Option Explicit

Sub Ascii_Bosluk_Sil()
    Dim Veri As Variant, Son As Long, X As Long, Y As Byte, Zaman As Double

    Zaman = Timer

    Son = Cells(Rows.Count, 1).End(3).Row
    Veri = Range("A3:P" & Son).Value

    ReDim Liste(1 To UBound(Veri), 1 To 15)

    For X = 1 To UBound(Veri)
        For Y = 1 To 15
            Liste(X, Y) = Trim(Replace(Veri(X, Y), Chr(13), ""))
        Next
    Next

    Range("A3").Resize(X - 1, 15) = Liste

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

 

[metin_0606]

Alternatif;

Hız olarak avantaj sağlayabilir.

A sütunu için;

Option Explicit

Sub Ascii_Bosluk_Sil()
    Dim Veri As Variant, Son As Long, X As Long, Zaman As Double

    Zaman = Timer

    Son = Cells(Rows.Count, 1).End(3).Row
    Veri = Range("A3:A" & Son).Value

    ReDim Liste(1 To UBound(Veri), 1 To 1)

    For X = 1 To UBound(Veri)
        Liste(X, 1) = Replace(Veri(X, 1), Chr(13), "")
    Next

    Range("A3").Resize(X - 1) = Liste

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

A-P sütun aralığı için;

Option Explicit

Sub Ascii_Bosluk_Sil()
    Dim Veri As Variant, Son As Long, X As Long, Y As Byte, Zaman As Double

    Zaman = Timer

    Son = Cells(Rows.Count, 1).End(3).Row
    Veri = Range("A3:P" & Son).Value

    ReDim Liste(1 To UBound(Veri), 1 To 15)

    For X = 1 To UBound(Veri)
        For Y = 1 To 15
            Liste(X, Y) = Replace(Veri(X, Y), Chr(13), "")
        Next
    Next

    Range("A3").Resize(X - 1, 15) = Liste

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

Tşkler Korhan bey tam istediğim gibi

 

[metin_0606]

Toplam 171.000 hücrenin her birinde chr(13) mevcut. Benim bilgisayarda 4 saniye sürüyor. Deneyiniz.

Tşkler yardımlarınız için

 

[Korhan Ayhan]

İşlem süresi nedir? Ne kadar avantaj sağladı?

 

[metin_0606]

İşlem süresi nedir? Ne kadar avantaj sağladı?

İkinci makronuzu denedim 3 sn de bitirdi işlemi

 

[metin_0606]

İşlem süresi nedir? Ne kadar avantaj sağladı?

Korhan bey bu verdiğiniz kodu hem kelimenin başındaki hemde sonundaki boşluğu silecek şekilde revize edebilirmiyiz

 

[Korhan Ayhan]

Üstteki mesajımı revize ettim.