excel Out Of Memory Sorunu

Sub aktar()

'Tbas = Now

Dim rg As Range

Dim son, sonstn, zSon, SonSatir As Long

Dim dizi As Variant

Dim puDizi As Variant

Dim iSonSutun As Integer





iSonSutun = Sayfa1.Cells(4, Columns.Count).End(xlToLeft).Column



Dim isim As String, aktif As Boolean

son = Sayfa1.Cells(Rows.Count, 4).End(xlUp).Row

'MsgBox iSonSutun

Set rg = Sayfa1.Range("4:" & iSonSutun & son)

dizi = rg

 With Application

        .DisplayAlerts = False

        .ScreenUpdating = False

        .EnableEvents = False

        .Calculation = xlCalculationManual

    End With

Sayfa37.Range("A3:N5000").Clear



m = -1

ReDim puDizi(100, 1568)



For i = 1 To UBound(dizi)

    If dizi(i, 2) = "True" Then

        isim = dizi(i, 4)

        m = m + 1

    End If

    

    

If dizi(i, 4) = isim Then

puDizi(m, 0) = m + 1

puDizi(m, 1) = dizi(i, 4)



If dizi(i, 5) <> "" Then a = dizi(i, 5)

puDizi(m, 2) = a





If dizi(i, 12) = "101" Then

puDizi(m, 3) = dizi(i, iSonSutun)

b = dizi(i, iSonSutun)

End If

If dizi(i, 12) = "119" Then

puDizi(m, 4) = dizi(i, iSonSutun)

c = dizi(i, iSonSutun)

End If

If dizi(i, 12) = "103" Then

puDizi(m, 5) = dizi(i, iSonSutun)

f = dizi(i, iSonSutun)

End If

If dizi(i, 12) = "117" Then

puDizi(m, 6) = dizi(i, iSonSutun)

d = dizi(i, iSonSutun)

End If

If dizi(i, 12) = "116" Then

puDizi(m, 7) = dizi(i, iSonSutun)

e = dizi(i, iSonSutun)

End If



If dizi(i, 12) = "106" Then

puDizi(m, 8) = dizi(i, iSonSutun)

bel = dizi(i, iSonSutun)

End If

puDizi(m, 13) = b + c + d + e + f + bel



End If

   

Next i



Sayfa37.Range("A3").Resize(m + 1, UBound(puDizi)) = puDizi

With Application

    .DisplayAlerts = True

    .ScreenUpdating = True

    .EnableEvents = True

    .Calculation = xlCalculationAutomatic

    .StatusBar = False

End With

'Sayfa37.Range("A" & m + 5 & ":N5000").Clear

Sayfa37.Range("A3:N" & m + 4).Borders.LineStyle = xlSolid

Sayfa37.Range("D3:N" & m + 4).HorizontalAlignment = xlCenter

Sayfa37.Range("B" & m + 4) = "Toplam"

Sayfa37.Range("d" & m + 4) = Application.WorksheetFunction.Sum(Sayfa37.Range("D3
Sayfa37.Range("e" & m + 4) = Application.WorksheetFunction.Sum(Sayfa37.Range("e3:e" & m + 3))

Sayfa37.Range("f" & m + 4) = Application.WorksheetFunction.Sum(Sayfa37.Range("f3:f" & m + 3))

Sayfa37.Range("g" & m + 4) = Application.WorksheetFunction.Sum(Sayfa37.Range("g3:g" & m + 3))

Sayfa37.Range("h" & m + 4) = Application.WorksheetFunction.Sum(Sayfa37.Range("h3:h" & m + 3))

Sayfa37.Range("i" & m + 4) = Application.WorksheetFunction.Sum(Sayfa37.Range("i3:i" & m + 3))

Sayfa37.Range("n" & m + 4) = Application.WorksheetFunction.Sum(Sayfa37.Range("n3:n" & m + 3))



With Sayfa37.Range("n3:n" & m + 4)

            .Interior.Color = RGB(217, 217, 217)

            .Font.Bold = True

            .Font.Size = 12

            .HorizontalAlignment = xlCenter

            .Borders.LineStyle = xlSolid

End With

 With Sayfa37.Range("A" & m + 4 & ":N" & m + 4)

            .Interior.Color = RGB(217, 217, 217)

            .Font.Bold = True

            .Font.Size = 12

            .HorizontalAlignment = xlCenter

            .Borders.LineStyle = xlSolid

            

        End With



zSon = Sayfa37.Cells(Rows.Count, 14).End(xlUp).Row '14 ==> N sütunu

Sayfa37.Range("N3") = "=sum(D3:M3)"

Sayfa37.Range("N3:N" & zSon).FillDown



'Başlık Yazdırma

Sayfa37.Cells(1, 1) = Worksheets("Ayar").Cells(7, 1) & Chr(10) & UCase(Replace(Replace(Format(Worksheets("Ayar").Cells(1, 1), "MMMM"), "ı", "I"), "i", "İ") & " " & "AYI EK DERS ÇİZELGESİ" & " (" & Worksheets("ayar").Cells(15, 1) & ")")





'Onaylayan bilgisi

 SonSatir = Sheets("Puantaj2").Cells(Rows.Count, 1).End(xlUp).Row 'Dolu son Satırı Bul

'Tarih Yazdır

Sayfa37.Range(Sayfa37.Cells(SonSatir + 4, 11), Sayfa37.Cells(SonSatir + 4, 13)).Merge 'Hücre birleştir

Sayfa37.Range(Sayfa37.Cells(SonSatir + 4, 11), Sayfa37.Cells(SonSatir + 4, 13)).HorizontalAlignment = xlCenter 'Birleştirilen Hücreleri Ortala

Sayfa37.Cells(SonSatir + 4, 11) = Date 'Birleştirilen Hücreye Tarih Bas

'Müdür YAzdır

Sayfa37.Range(Sayfa37.Cells(SonSatir + 6, 11), Sayfa37.Cells(SonSatir + 6, 13)).Merge 'Hücre birleştir

Sayfa37.Range(Sayfa37.Cells(SonSatir + 6, 11), Sayfa37.Cells(SonSatir + 6, 13)).HorizontalAlignment = xlCenter 'Birleştirilen Hücreleri Ortala

Sayfa37.Cells(SonSatir + 6, 11) = Worksheets("Ayar").Cells(5, 1)

'Unvan Yazdır

Sayfa37.Range(Sayfa37.Cells(SonSatir + 7, 11), Sayfa37.Cells(SonSatir + 7, 13)).Merge 'Hücre birleştir

Sayfa37.Range(Sayfa37.Cells(SonSatir + 7, 11), Sayfa37.Cells(SonSatir + 7, 13)).HorizontalAlignment = xlCenter 'Birleştirilen Hücreleri Ortala

Sayfa37.Cells(SonSatir + 7, 11) = Worksheets("Ayar").Cells(6, 1)



MsgBox ("Veriler Başarıyla MEB Çizelgeye aktarıldı") ' Tbit & " - " & Tbas)

End Sub

"out of memory" hatası alıyorum. Yardımcı olabilir misiniz?

Out Of Memory hatası kodunuz çalışırken bilgisayarınızın bellek kapasitesinin sonuna geldiği anlamına gelir. Bütün işlemleri tek bir kodun içinde yapmak yerine işlemi parçalara ayırmayı ve kodunuzu optimize etmeyi deneyin ve işlemlerinizin sırasına göre işi biten değişkenleri boşaltıp belleğinizde yer açın.
optimize etmeye çalışırken tek bir kod yöntemine döngüye odaklanmayın. Mesela aşağıdaki kod ile kendi kodunuzu karşılaştırın örnek olarak sizin kodlarınızı kısmen optimize edecek olursak:

Kod:
Dim ws1 As Worksheet, ws2 As Worksheet, wsAyar As Worksheet

    Dim dataRange As Range

    Dim resultRange As Range

    Dim lastRow As Long

    Dim i As Long

    Dim puDizi() As Variant

    Dim m As Long

    Dim b As Double, c As Double, d As Double, e As Double, f As Double, bel As Double

    Dim isim As String

    Application.ScreenUpdating = False

    Application.Calculation = xlCalculationManual

    Application.DisplayAlerts = False

    Application.EnableEvents = False

    Set ws1 = ThisWorkbook.Sheets("Sayfa1")

    Set ws2 = ThisWorkbook.Sheets("Sayfa37")

    Set wsAyar = ThisWorkbook.Sheets("Ayar")

    lastRow = ws1.Cells(ws1.Rows.Count, 4).End(xlUp).Row

    Set dataRange = ws1.Range("A4:N" & lastRow)

    Set resultRange = ws2.Range("A3:N5000")

    resultRange.Clear

    m = -1

    ReDim puDizi(100, 13)

    For i = 1 To dataRange.Rows.Count

        If dataRange.Cells(i, 2).Value = True Then

            isim = dataRange.Cells(i, 4).Value

            m = m + 1

        End If

        If dataRange.Cells(i, 4).Value = isim Then

            ' Verileri işle

            If dataRange.Cells(i, 5) <> "" Then

                puDizi(m, 2) = dataRange.Cells(i, 5).Value

            End If

            Select Case dataRange.Cells(i, 12).Value

                Case "101"

                    b = dataRange.Cells(i, dataRange.Columns.Count).Value

                Case "119"

                    c = dataRange.Cells(i, dataRange.Columns.Count).Value

                Case "103"

                    f = dataRange.Cells(i, dataRange.Columns.Count).Value

                Case "117"

                    d = dataRange.Cells(i, dataRange.Columns.Count).Value

                Case "116"

                    e = dataRange.Cells(i, dataRange.Columns.Count).Value

                Case "106"

                    bel = dataRange.Cells(i, dataRange.Columns.Count).Value

            End Select

        End If

        puDizi(m, 0) = m + 1

        puDizi(m, 1) = isim

        puDizi(m, 3) = b

        puDizi(m, 4) = c

        puDizi(m, 5) = f

        puDizi(m, 6) = d

        puDizi(m, 7) = e

        puDizi(m, 8) = bel

        puDizi(m, 13) = b + c + d + e + f + bel

    Next i

    resultRange.Resize(m + 1, UBound(puDizi, 2)).Value = puDizi

    resultRange.Borders.LineStyle = xlSolid

    resultRange.HorizontalAlignment = xlCenter

    ' Diğer işlemler

    ' ...

    Application.ScreenUpdating = True

    Application.Calculation = xlCalculationAutomatic

    Application.DisplayAlerts = True

    Application.EnableEvents = True

gibi kodlarınızı sadeleştirmeyi ve örneğin önce aktarımı sonra formatlamayı yapmak gibi parçalara bölmeyi de değerlendirin.

Sayın Atoykan teşekkür ediyorum.
Dediklerinizi dikkate alıp tekrar deneyeceğim...

excel Out Of Memory Sorunu

martineden-30

atoykan

martineden-30