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

search77

Altın Üye
Katılım
21 Temmuz 2006
Mesajlar
275
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,126
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.
 

search77

Altın Üye
Katılım
21 Temmuz 2006
Mesajlar
275
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
946
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
 

search77

Altın Üye
Katılım
21 Temmuz 2006
Mesajlar
275
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
2,910
Excel Vers. ve Dili
Excel 2010-TR (32 bit)
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

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
32,305
Excel Vers. ve Dili
Ofis 365 Tr-64 Bit
Ofis 2010 Tr-En 32 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