Transposede büyüklük kısıtlaması

[Orion1]

Merhaba.
Aşağıdaki kodlarla A sütununda 65536 satırı geçen verilerim var.
Kullandığım yöntemle verileri almak istiyorum,ama dizide boyut yerlerini değiştirdiğimde transpose 65536 satırı geçemediği için hata veriyor.
Verilerim 65568 benzesiz dir.
örnek dosyayı yüklüyorum.Bunu nasıl aşmalıyım.Ado kullanmadan bu yöntemle çözmek istiyorum.

DOSYAYI İNDİR

Option Base 1
Sub transpose59()
Dim myarr(), z As Object, i As Long, n As Long, j As Long
Range("G:I").Clear
j = 65568
ReDim myarr(1 To 3, 1 To j)
Set z = CreateObject("Scripting.dictionary")
For i = 1 To 65568
    If Not z.exists(Cells(i, "A").Value) Then
        n = n + 1
        z.Add Cells(i, "A").Value, n
        myarr(1, n) = Cells(i, "A").Value
    End If
    myarr(2, z.Item(Cells(i, "A").Value)) = Cells(i, "B").Value
    myarr(3, z.Item(Cells(i, "A").Value)) = Cells(i, "C").Value
Next i
ReDim Preserve myarr(1 To 3, 1 To n)
Range("G1").Resize(n, 3) = Application.Transpose(myarr)
End Sub

 

[Ziynettin]

Merhaba Evren Bey.
Farklı cevaplar olabilir. Tekrar döngü kurarak olabilir.

Sub transpose59()
Dim myarr(), z As Object, i As Long, n As Long, j As Long
Range("G:I").Clear
j = 65568
ReDim myarr(1 To 3, 1 To j)
Set z = CreateObject("Scripting.dictionary")
For i = 1 To j
    If Not z.exists(Cells(i, "A").Value) Then
        n = n + 1
        z.Add Cells(i, "A").Value, n
        myarr(1, n) = Cells(i, "A").Value
    End If
    myarr(2, z.Item(Cells(i, "A").Value)) = Cells(i, "B").Value
    myarr(3, z.Item(Cells(i, "A").Value)) = Cells(i, "C").Value
Next i

If z.Count > 0 Then
    ReDim b(1 To z.Count, 1 To 3)
        For i = 1 To z.Count
            s = s + 1
            b(s, 1) = myarr(1, i)
            b(s, 2) = myarr(2, i)
            b(s, 3) = myarr(3, i)
        Next i
    Range("G1").Resize(n, 3) = b
End If
End Sub

Ya da;

Listeyi yeniden boyutlandırmadan tek döngü ile de olabilir.

 

[Orion1]

Teşekkür ederim.
Evet bu yöntemle olabilir.
Listeyi yeniden boyutlandırmadan nasıl olur.Birde o yöntemle yaparmısınız?

 

[Orion1]

Tekrar döngüye girmeye gerek kalmadı.
Transpose yi kaldırıdım.Preserve satırınıda sildim.
Resize da işi bitirdim.Fazla satırı orada kısıtlıyorum.Kaç satır varsa o kadarını resize da n değişkeni ile sınırlıyorum.
Tekrar teşekkür edrim.İyi çalışmalar dilerim.

 

[Ziynettin]

Ben yine de hazılamıştım.

Sub transpose59()
Dim myarr(), z As Object, i As Long, n As Long, j As Long
t = TimeValue(Now)
Range("G:I").Clear
j = 65568
ReDim myarr(1 To j, 1 To 3)
Set z = CreateObject("Scripting.dictionary")
For i = 1 To j
    If Not z.exists(Cells(i, "A").Value) Then
        n = n + 1
        z.Add Cells(i, "A").Value, n
        myarr(n, 1) = Cells(i, "A").Value
    End If
    myarr(z.Item(Cells(i, "A").Value), 2) = Cells(i, "B").Value
    myarr(z.Item(Cells(i, "A").Value), 3) = Cells(i, "C").Value
Next i

If z.Count > 0 Then
    [G1].Resize(n, 3) = myarr
End If
MsgBox CDate(TimeValue(Now) - t), vbInformation
End Sub

Tabloyu dizi boyut olarak;

Sub transpose59()
Dim myarr(), z As Object, i As Long, n As Long, j As Long, Liste()
t = TimeValue(Now)
Range("G:I").Clear
j = 65568

Liste = Range("A1:C" & j).Value

ReDim myarr(1 To j, 1 To 3)

Set z = CreateObject("Scripting.dictionary")
For i = 1 To j
    If Not z.exists(Liste(i, 1)) Then
        n = n + 1
        z.Add Liste(i, 1), n
        myarr(n, 1) = Liste(i, 1)
    End If
    myarr(z.Item(Liste(i, 1)), 2) = Liste(i, 2)
    myarr(z.Item(Liste(i, 1)), 3) = Liste(i, 3)
Next i

If z.Count > 0 Then
    [G1].Resize(n, 3) = myarr
End If
MsgBox CDate(TimeValue(Now) - t), vbInformation
End Sub

 

[Orion1]

Tekrar teşekkür ederim.

 

[Orion1]

Listboxa veri alırken diziden diziye aktarma yaparak alınabilir.
Veya aktarma yapmadan sayfaya aktarıp ,listboxa oaradn rowsource yöntemi ile veri alınabilir.

 

[FERAZ]

Ben yine de hazılamıştım.

Sub transpose59()
Dim myarr(), z As Object, i As Long, n As Long, j As Long
t = TimeValue(Now)
Range("G:I").Clear
j = 65568
ReDim myarr(1 To j, 1 To 3)
Set z = CreateObject("Scripting.dictionary")
For i = 1 To j
    If Not z.exists(Cells(i, "A").Value) Then
        n = n + 1
        z.Add Cells(i, "A").Value, n
        myarr(n, 1) = Cells(i, "A").Value
    End If
    myarr(z.Item(Cells(i, "A").Value), 2) = Cells(i, "B").Value
    myarr(z.Item(Cells(i, "A").Value), 3) = Cells(i, "C").Value
Next i

If z.Count > 0 Then
    [G1].Resize(n, 3) = myarr
End If
MsgBox CDate(TimeValue(Now) - t), vbInformation
End Sub

Tabloyu dizi boyut olarak;

Sub transpose59()
Dim myarr(), z As Object, i As Long, n As Long, j As Long, Liste()
t = TimeValue(Now)
Range("G:I").Clear
j = 65568

Liste = Range("A1:C" & j).Value

ReDim myarr(1 To j, 1 To 3)

Set z = CreateObject("Scripting.dictionary")
For i = 1 To j
    If Not z.exists(Liste(i, 1)) Then
        n = n + 1
        z.Add Liste(i, 1), n
        myarr(n, 1) = Liste(i, 1)
    End If
    myarr(z.Item(Liste(i, 1)), 2) = Liste(i, 2)
    myarr(z.Item(Liste(i, 1)), 3) = Liste(i, 3)
Next i

If z.Count > 0 Then
    [G1].Resize(n, 3) = myarr
End If
MsgBox CDate(TimeValue(Now) - t), vbInformation
End Sub

Merhaba.

myarr(z.Item(Liste(i, 1)), 2) = Liste(i, 2)
myarr(z.Item(Liste(i, 1)), 3) = Liste(i, 3)

ile

myarr(i, 2) = Liste(i, 2)
myarr(i, 3) = Liste(i, 3)

Bu kodu değiştirdim aynı sonuç verdi.
Bu dictionary olayında kafam z.Item(Liste(i, 1)) bu kısma bir türlü basmıyor.Daha öncede bir sürü bbenzer kodlarla karşılaştım nafile.
Anladığım İtem ile alakalı fakat nasıl bir mantık var anlayamadım.
Aydınlatabilirse bir kişi memnun olurum.
Yani item olayını kafa almıyor o kadar video izlememe rağmen dictionary hakkında