Çözüldü Redim ve Dictionary hata.(65536 satır sonrası)

[FERAZ]

Merhaba.

Alttaki kod 34464 üncü satıra kadar sayı ekliyor.Sonraki satırlara #YOK hatası ekliyor.
Neden 100000 e kadar eklemediğini öğrenebilir miyim?

Saygılar.

Sub x()

    Dim arr()
    Dim i As Long
    [A:A] = Empty
    ReDim arr(1 To 100000)
    Application.Calculation = xlCalculationManual
    
    For i = 1 To 100000
        arr(i) = i
    Next
    
    Range("A1:A" & UBound(arr)).Value = Application.Transpose(arr)

    Application.Calculation = xlCalculationAutomatic
    
    Erase arr
End Sub

 

[FERAZ]

100000 leri 65536 yapınca normal oldu.Heralde 65536 a göre ayarlı

 

[ÖmerBey]

Merhaba,
Bu durum transpose limitiyle alakalı. Limit aşıldığı için hata alıyorsunuz.
Alternatif olarak aşağıdaki kodu deneyebilirsiniz. İyi çalışmalar...

Sub kod()
With Range("A1:A100000")
    .Formula = "=ROW()"
    .Value = .Value
End With
End Sub

 

[FERAZ]

Sağolun.

Sadece bir örnekti kod.Dediğiniz gibi limit ile alakalı bencede.Neden 65536 ya kadar buda garip.Redim olayı hızlı olduğu için sormuştum.

 

[Zeki Gürsoy]

Kullanıcı tanımlı transpose fonksiyonu ile bu sorun aşılabilir...

 

[FERAZ]

Bir örnek kod yazabilir misiniz Zeki Hocam?

 

[Zeki Gürsoy]

Bir örnek kod yazabilir misiniz Zeki Hocam?

Elbette. Ben de şimdi onu deniyordum...

Sub x()

    Dim arr()
    Dim i As Long
    [A:A] = Empty
    ReDim arr(1 To 100000)
    Application.Calculation = xlCalculationManual
    
    For i = 1 To 100000
        arr(i) = i
    Next
    
    Range("A1:A" & UBound(arr)).Value = MyTranspose(arr)

    Application.Calculation = xlCalculationAutomatic
    
    Erase arr
End Sub

Function MyTranspose(MyArray)
    Dim vArray()
    
    ReDim vArray(1 To UBound(MyArray), 1 To 1)
    
    Dim L As Long
    
    For L = 1 To UBound(MyArray)
        vArray(L, 1) = MyArray(L)
    Next
    
    MyTranspose = vArray
End Function

 

[halit3]

Alternatif olsun

Sub test5()
Dim veri(), k As Long
Application.Calculation = xlCalculationManual
k = 100000
ReDim veri(1 To k, 1 To 1)

Application.ScreenUpdating = False
With Range("a1")
For i = 1 To k
veri(i, 1) = i
Next i
.Resize(k, 1).Value = veri
End With
Application.Calculation = xlCalculationAutomatic
MsgBox "işlem tamam"
End Sub

 

[FERAZ]

Halit ve Zeki hocam elinize sağlık denedim ve süper hızlı çalıştı.

Hayırlı geceler herkese.

 

[Korhan Ayhan]

Diziyi iki boyutlu tanımladığınızda sorun ortadan kalkıyor.

Benzer bir alternatif.. (1 Milyon satır..)

Sub Test()
    Dim arr()
    Dim i As Long
    [A:A] = Empty
    ReDim arr(1 To 1000000, 1 To 1)
    Application.Calculation = xlCalculationManual
    
    For i = 1 To 1000000
        arr(i, 1) = i
    Next
    
    Range("A1:A" & UBound(arr)).Value = arr

    Application.Calculation = xlCalculationAutomatic
    
    Erase arr
End Sub

 

[FERAZ]

Korhan hocam sağolun.
Yarın deneyebilirim gerçi siz denemişsiniz.
Transpose gereken yerlerde diğerlerini,gerekmeyen yerlerde bunu kullanırım.
Dizi olayı kullanırken hep transpose ile yapıyordum bu şekilde yapma olayını unutmuştum

 

[ÖmerBey]

Korhan Bey'in 2 boyutlu dizi tavsiyesini görünce bir alternatif de benim aklıma geldi.
Mantık aynı ama yol farklı, deneyiniz...
İyi çalışmalar...

Sub kod()
dz = Range("A:A")
For a = LBound(dz) To UBound(dz)
    dz(a, 1) = a
Next
Range("A:A") = dz
End Sub

 

[FERAZ]

Diziyi iki boyutlu tanımladığınızda sorun ortadan kalkıyor.

Benzer bir alternatif.. (1 Milyon satır..)

Sub Test()
    Dim arr()
    Dim i As Long
    [A:A] = Empty
    ReDim arr(1 To 1000000, 1 To 1)
    Application.Calculation = xlCalculationManual
   
    For i = 1 To 1000000
        arr(i, 1) = i
    Next
   
    Range("A1:A" & UBound(arr)).Value = arr

    Application.Calculation = xlCalculationAutomatic
   
    Erase arr
End Sub

Süper çalıştı.Elinize sağlık.

 

[FERAZ]

Korhan Bey'in 2 boyutlu dizi tavsiyesini görünce bir alternatif de benim aklıma geldi.
Mantık aynı ama yol farklı, deneyiniz...
İyi çalışmalar...

Sub kod()
dz = Range("A:A")
For a = LBound(dz) To UBound(dz)
    dz(a, 1) = a
Next
Range("A:A") = dz
End Sub

Kod 1048576 ya kadar 3 saniye sürdü. Elinize sağlık süper.

 

[FERAZ]

Daha önce başka bir Foruma sormuştum.Bu konuyu açınca aklıma geldi.Acaba alttaki kod içinde bir çözüm var mıdır?
Dicyionary ile olmalı.

Dim i As Long
   
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
   
    Columns(2).Clear
    Columns(3).Clear
    For i = 1 To 70000
        Dict.Add i, i * 10
    Next
    Range("B1").Resize(Dict.Count, 1) = Application.Transpose(Dict.Keys)
    Range("C1").Resize(Dict.Count, 1) = Application.Transpose(Dict.Items)
   
    Set Dict = Nothing

End Sub

 

[ÖmerBey]

Tekrar merhaba,
Önceki isteğiniz için yukarıda sunduğum çözümlerin son isteğinize uyarlanmış halleri aşağıdadır, inceleyiniz...

Sub kod()
Range("B1:B70000").Formula = "=ROW()"
Range("C1:C70000").Formula = "=ROW()*10"
Range("B1:C70000").Value = Range("B1:C70000").Value
End Sub

Sub kod1()
dz = Range("B1:C70000")
For i = LBound(dz) To UBound(dz)
    dz(i, 1) = i
    dz(i, 2) = i * 10
Next
Range("B1:C70000") = dz
End Sub

 

[FERAZ]

Ömer hocam kodlar deneme içindi.Yani Scripting.Dictionary 65536 dan sonrası için olmuyor.

Kodun içinde Scripting.Dictionary olmalı.
Teşekkürler.

 

[Orion1]

Daha önce başka bir Foruma dormuştum.Bu konuyu açınca aklıma geldi.Acaba alttaki kod içinde bir çözüm var mıdır?
Dicyionary ile olmalı.

Dim i As Long
   
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
   
    Columns(2).Clear
    Columns(3).Clear
    For i = 1 To 70000
        Dict.Add i, i * 10
    Next
    Range("B1").Resize(Dict.Count, 1) = Application.Transpose(Dict.Keys)
    Range("C1").Resize(Dict.Count, 1) = Application.Transpose(Dict.Items)
   
    Set Dict = Nothing

End Sub

buyurun.

Sub myscripting59()
    Dim i As Long, myarr()
    
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    ReDim myarr(1 To 70000, 1 To 2)
    Columns(2).Clear
    Columns(3).Clear
    For i = 1 To 70000
        Dict.Add i, i * 10
        myarr(i, 1) = i
        myarr(i, 2) = i * 10
    Next
    Range("B1").Resize(Dict.Count, 2) = myarr
    Set Dict = Nothing
    Erase myarr

End Sub

 

[FERAZ]

Sağolunuz Orion1 hocam.Sorun çözüldü sayenizde

 

[Orion1]

Sağolunuz Orion1 hocam.Sorun çözüldü sayenizde

Rica ederim.
İyi çalışmalar.