Dosyadaki makroyu hızlandırmanın bir yolu var mı?

[Tevfik_Kursun]

Merhaba Arkadaşlar,
Dosyadaki makroyu hızlandırmanın bir yolu var mıdır?
Saygılarımla

 

[ÖmerFaruk]

Dosyanızda ne yapmaya çalıştığınızı anlamadım.
ilk for döngüsünde aşağıdaki satırınız var.
Cells(x, 5) = Left(Cells(x, 4), 1) & Right(Cells(x, 4), 1)
Bu satırda zaten tamamen 2 karakterden oluşan karakter dizisi oluşmak zorundadır.
Left(Cells(x, 4), 1) Soldaki ilk karakter
Right(Cells(x, 4), 1) Sağdaki ilk karakter.

Devamında yaptığınız yeni döngüler ve if sorguları oldukça gereksiz. Eğer yukarıdaki işlemi bilerek yapıyorsanız.
Doğru dosyayı göndermediğinizi de düşünüyorum aslında.

Ayrıca mevcut makroyla ne yapmaya çalıştığınızı ifade etseniz daha faydalı olacak.

 

[Necdet]

Merhaba,

ÖmerFaruk beye katılıyorum. Çok özensiz bir soru olmuş.

 

[Korhan Ayhan]

Merhaba,

Kodu hızlandırmak için hücre başvurularından kurtulmanız gerekir. Dizi yöntemiyle epey hız kazanabilirsiniz.

Diğer arkadaşlarıma bende katılıyorum. Ne yapmak istediğinizi açıklamanız gerekir.

 

[Tevfik_Kursun]

Merhaba Arkadaşlar,
İlgileriniz için çok teşekkür ederim. Anlatamamışım, özür dilerim.
Ad soyadların baş harflerinden oluşan liste. birden çok adı olan insanlar var.
Tevfik Kurşun için 4. sütuna TK gelmiş ve 5. sütuna TK gelir
Ali Sami Yen için 4. sütuna ASY gelmiş ve 5. sütuna AY, 6. sütuna SY gelir
Ali Veli Sadi Tut için AVST 4.sütuna gelmiş ve 5. sütuna AT, 6. sütuna VT, 7. sütuna ST gelir.
Kişilere erişim kolaylığı açısından çok işe yarıyor. D sütunundaki 213409 kişilik bir liste. Korhan Ayhan Hocanın çalişması ila 1,12 sn de gerçek isimlerden oluşturulabiliyor. Ayrıştırmak 52 saniyenin üzerinde.
Dizi yönteminin işe yarayacağını düşünmüştüm, ama uyarlayamadım. Bu mesajdaki ince ayrıntıyı önce anlatmış olsam çok iyi olurmuştu. Umarım yine de cevap veren olur.
Saygılarımla

 

[ÖmerFaruk]

Sonuçları kontrol ederseniz sevinirim.

Sub Parcala()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Zaman = Timer
    Dim Son As Long, x As Long, Dizi()
    Son = Cells(Rows.Count, "D").End(3).Row
    Dizi = Range("D1").Resize(Son, 1).Value
    ReDim Liste(1 To UBound(Dizi), 1 To 4)
    For i = 1 To UBound(Dizi)
        Liste(i, 1) = Left(Dizi(i, 1), 1) & Right(Dizi(i, 1), 1)
        If Len(Dizi(i, 1)) > 2 Then Liste(i, 2) = Mid(Dizi(i, 1), Len(Dizi(i, 1)) - 1, 1) & Right(Dizi(i, 1), 1)
        If Len(Dizi(i, 1)) > 3 Then Liste(i, 3) = Mid(Dizi(i, 1), Len(Dizi(i, 1)) - 2, 1) & Right(Dizi(i, 1), 1)
        If Len(Dizi(i, 1)) > 4 Then Liste(i, 4) = Right(Dizi(i, 1), 2)
    Next i
    Range("E1").Resize(UBound(Dizi), 4) = Liste
    [L1] = Format(Timer - Zaman, "0.00")
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

 

[Tevfik_Kursun]

Sayın Ömer Faruk Hocam,
İlginize teşekkür ederim. 1,73 sn. Son uğraşımla 11 sn ye indirebilmiştim.
Saygılarımla

 

[ÖmerFaruk]

OK.
Verdiğim kodlarda i değişkenini Long olarak tanımlamalıyız
Application.DisplayAlerts = False/true bu satırları silebilirsin

 

[veyselemre]

Örnek olsun.

Sub test()

    Dim son&, mx As Byte, veri(), lst(), i&, ii As Byte
    son = Cells(Rows.Count, 4).End(3).Row
    'mx = Evaluate("MAX(LEN(D1:D" & son & "))")
    mx = 4
    veri = Range("D1:D" & son).Value
    ReDim lst(1 To UBound(veri), 1 To mx)
    For i = 1 To UBound(veri)
        For ii = 1 To Len(veri(i, 1)) - 1
            lst(i, ii) = Mid(veri(i, 1), ii, 1) & Right(veri(i, 1), 1)
        Next ii
    Next i
    Range("E1").Resize(UBound(veri), mx).Value = lst

End Sub

 

[Tevfik_Kursun]

Sayın Veysel Emre Hocam,
İlginize çok teşekkür ederim. Ortaya çıkan çiftleri tekrarsız ve alfabetik sırada M1 den itibaren de sıralayabilir miyiz?
Saygılarımla

 

[veyselemre]

Sub test()

    Dim son&, mx As Byte, veri(), lst(), i&, ii As Byte, a$
    son = Cells(Rows.Count, 4).End(3).Row
    'mx = Evaluate("MAX(LEN(D1:D" & son & "))")
    mx = 4
    veri = Range("D1:D" & son).Value
    ReDim lst(1 To UBound(veri), 1 To mx)
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(veri)
            For ii = 1 To Len(veri(i, 1)) - 1
                a = Mid(veri(i, 1), ii, 1) & Right(veri(i, 1), 1)
                lst(i, ii) = a
                .Item(a) = Null
            Next ii
        Next i
        veri = .keys
    End With
    Range("E1").Resize(UBound(lst), mx).Value = lst
    With Range("M1").Resize(UBound(veri), 1)
        .Value = Application.Transpose(veri)
        .Sort Range("M1")
    End With

End Sub

 

[Tevfik_Kursun]

Sayın Veysel Emre Hocam,
Çok teşekkür ederim.
Saygılarımla