Transpose yapan macro çok yavaş çalışıyor

[search77]

Arkadaşlar Merhaba,
Ekli örnek dosyamdaki transpose yapan macro 200 binlik kayıtta kilitleniyor.
Bunu nasıl hızlandırabiliriz.
Macro içeriği dosya içinde mevcut.
Yardımcı olabileceklere şimdiden minnettarım.
Saygılar.

 

[Orion1]

Yanlış hatırlamıyorsam,Transpose 32 bin kadar bir miktarı transpose edilebiliyor.

 

[search77]

Bu macro ile aslında 200 binlik satırı yapıyor, fakat çok yavaş yazıyor, yazılanları görüyorum o derece yani

Ama macroda bir kısıt yok, A:A kolonu 100 binde olsa 200 binde olsa yapıyor sorunsuz çalışıyor, fakat çok çok yavaş

 

[Ziynettin]

Bu kodu kullanın.

Sub Listele()
Set ds = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Sheets("sheet1").Select
Z = TimeValue(Now)
son = Cells(Rows.Count, "A").End(3).Row

If son < 2 Then Exit Sub
a = Range("A1:B" & son).Value

For i = 2 To UBound(a)
    krt = a(i, 1)
    ds(krt) = ds(krt) + 1
    dc(krt) = dc(krt) & "|" & a(i, 2)
Next i


sat = dc.Count
sut = Application.Max(ds.items) + 1
v1 = dc.keys
v2 = dc.items

ReDim b(1 To sat, 1 To sut)

For i = 1 To sat
    b(i, 1) = v1(i - 1)
    v3 = Split(v2(i - 1), "|")
    For j = 1 To UBound(v3)
        b(i, j + 1) = v3(j)
    Next j
Next i

Application.ScreenUpdating = False
    On Error Resume Next
    sutun = Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    If Err.Number = 0 Then
        Range("E2", Cells(Rows.Count, sutun)).ClearContents
        Range("E2", Cells(Rows.Count, sutun)).ClearFormats
    End If
    On Error GoTo 0
    [E2].Resize(sat, sut) = b
    [E2].Resize(sat, sut).Borders.Color = rgbGrey
    Application.ScreenUpdating = True
    
MsgBox CDate(TimeValue(Now) - Z), vbInformation
End Sub

 

[search77]

Sayın Ziynettin,
Elinize kolunuza sağlık 10 numara olmuş,
300 bin kaydı 4 dakikada yaptı, harika harika harika
Saygılar.

 

[veyselemre]

Birde bu kodun 300 bin kayıttaki süresini ölçebilir misiniz?

Sub test()

    Dim a, b, i&, ky$, say&, s&, zaman
    zaman = Timer
    a = Range("A2:B" & Cells(Rows.Count, 1).End(3).Row).Value
    ReDim b(1 To UBound(a), 1 To 2)

    With CreateObject("Scripting.Dictionary")
        For i = LBound(a) To UBound(a)
            ky = a(i, 1)
            If Not .exists(ky) Then
                say = say + 1
                b(say, 1) = a(i, 1)
                b(say, 2) = a(i, 2)
                .Item(ky) = say
            Else
                s = .Item(ky)
                b(s, 2) = b(s, 2) & "|" & a(i, 2)
            End If
        Next i
    End With
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Range("E2", Cells(Rows.Count, Columns.Count)).Clear
    Range("E2").Resize(say, 2).Value = b
    Range("F2").Resize(say, 1).TextToColumns Destination:=[F2], other:=True, otherchar:="|"
    Range("F2").CurrentRegion.Borders.LineStyle = xlContinuous
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "Veri aktarimi tamamlanmistir." & Chr(10) & Chr(10) & _
           "Islem süresi ; " & Format(Timer - zaman, "0.00") & " Saniye", vbInformation

End Sub

 

[Korhan Ayhan]

@veyselemre,

Ben denedim.

10.000 benzersiz ID oluşturdum. 300.000 satırlık veride İ5 6. Nesil İşlemci 8 Gb Ram laptobumda oluşan sonuçlar aşağıdaki gibidir.

Sizin öneriniz ~2,50 saniye
Ziynettin beyin önerisi ~2,25 saniye