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" & m + 3))

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?