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

Katılım
21 Temmuz 2006
Mesajlar
313
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.
 

Ekli dosyalar

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,254
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
Yanlış hatırlamıyorsam,Transpose 32 bin kadar bir miktarı transpose edilebiliyor.
 
Katılım
21 Temmuz 2006
Mesajlar
313
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

Destek Ekibi
Destek Ekibi
Katılım
18 Nisan 2008
Mesajlar
1,104
Excel Vers. ve Dili
office2010
Bu kodu kullanın.

Kod:
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
 
Katılım
21 Temmuz 2006
Mesajlar
313
Sayın Ziynettin,
Elinize kolunuza sağlık 10 numara olmuş,
300 bin kaydı 4 dakikada yaptı, harika harika harika
Saygılar.
 

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,553
Excel Vers. ve Dili
Pro Plus 2021
Birde bu kodun 300 bin kayıttaki süresini ölçebilir misiniz?

Kod:
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

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,317
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
@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
 
Üst