Soru Neden dosyamı kapatırken out of memory uyarısı alıyorum?

[seckinb]

Merhaba

Dosyamı her kapattığımda bu şekilde bir uyarı alıyorum
Nasıl çözebilirim?

Teşekkürler

Private Sub CBdosya_Click()
'BOŞ OLUNCA DURDURMA
If Trim(tbAD.Value) = "" And Me.Visible Then
        MsgBox "Hasta adı giriniz", vbCritical, "Hata"
        Cancel = True
        Me.tbAD.SetFocus
        Exit Sub
        End If
If Trim(tbSoyad.Value) = "" And Me.Visible Then
        MsgBox "Hasta soyadı giriniz", vbCritical, "Hata"
        Cancel = True
        Me.tbSoyad.SetFocus
        Exit Sub
        End If
If Trim(tbDosyaNo.Value) = "" And Me.Visible Then
        MsgBox "Dosya numarasını boş bırakmayınız", vbCritical, "Hata"
        Cancel = True
        Me.tbDosyaNo.SetFocus
        Exit Sub
        End If
        
Dim str As String
Dim mystr As String

str = tbDosyaNo.Value
mystr = Left(str, 2)
'MsgBox mystr

Select Case CMBturu.Value
Case "Prostat_CA"

    Dim w1 As Workbook

    Dim DosyaAdi As String
    Dim owb As Workbook
    Dim owk1 As Worksheet
    
Set w1 = ThisWorkbook

anahedef = "S:\TRT\Prostat_Kanseri_PSMA\" & mystr & "XX\"
DosyaAdi = tbDosyaAdi.Value

If Len(Dir(anahedef, vbDirectory)) = 0 Then
       MkDir anahedef
End If

hedef = anahedef & DosyaAdi

kaynak = "S:\TRT\SABLONLAR\BOSPCA.XLSM"

If Len(Dir(hedef, vbDirectory)) = 0 Then
MkDir hedef
Shell "explorer.exe" & " " & hedef, vbNormalFocus
End If

'yeni dosyayi acip yeniden kaydediyor
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
Set owb = Application.Workbooks.Open(kaynak)

Set owk1 = owb.Worksheets("kimlik")

owk1.Cells(1, 3).Value = tbAD.Text
owk1.Cells(2, 3).Value = tbSoyad.Text
owk1.Cells(3, 3).Value = tbTCK.Text
owk1.Cells(5, 3).Value = tbDOGUMT.Text

owk1.Cells(1, 8).Value = tbCEP1.Text
owk1.Cells(2, 8).Value = tbCEP2.Text
owk1.Cells(3, 8).Value = tbGONDEREN.Text

With owb
     .SaveAs hedef & "\" & DosyaAdi & ".xlsm", 52
     '.Close
End With


Application.ScreenUpdating = True
owb.Activate

'formu kapatiyor
Hide


'w1.Close 0
'Kill w1

Case "NET"

Case Else
End Select

End Sub

Private Sub CMBtakibi_Change()
tbDosyaAdi.Value = tbDosyaNo.Text & "_" & tbAD.Text & "_" & tbSoyad.Text & "_" & CMBtakibi.Text
End Sub

Private Sub CMBturu_Change()
Select Case CMBturu.Value
Case "NET"
    Call klasör_dosya3
    Me.tbDosyaNo.Text = CStr(ThisWorkbook.Sheets("P3").Range("A2").Value + 1)
    Me.tbDosyaNo.Text = Format(tbDosyaNo.Text, "0000")
Case "Papiller_Tiroit_CA"
    Call klasör_dosya3
    Me.tbDosyaNo.Text = CStr(ThisWorkbook.Sheets("P3").Range("A2").Value + 1)
    Me.tbDosyaNo.Text = Format(tbDosyaNo.Text, "0000")
Case "Prostat_CA"
    Call klasör_dosya1
    Me.tbDosyaNo.Text = CStr(ThisWorkbook.Sheets("P1").Range("A2").Value + 1)
    Me.tbDosyaNo.Text = Format(tbDosyaNo.Text, "0000")
Case "Y90_HCC-KOLANJIO"
    Call klasör_dosya2
    Me.tbDosyaNo.Text = CStr(ThisWorkbook.Sheets("P2").Range("A2").Value + 1)
    Me.tbDosyaNo.Text = Format(tbDosyaNo.Text, "0000")
Case "Y90_METASTATIK"
    Call klasör_dosya2
    Me.tbDosyaNo.Text = CStr(ThisWorkbook.Sheets("P2").Range("A2").Value + 1)
    Me.tbDosyaNo.Text = Format(tbDosyaNo.Text, "0000")
Case Else
End Select
tbDosyaAdi.Value = tbDosyaNo.Text & "_" & tbAD.Text & "_" & tbSoyad.Text & "_" & CMBtakibi.Text
End Sub

Private Sub Kapat_Click()
Application.ScreenUpdating = True
Worksheets("Formlar").Select
Hide
End Sub

Private Sub tbAD_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If Trim(tbAD.Value) = "" And Me.Visible Then
    MsgBox "Hasta adı giriniz", vbCritical, "Hata"
    Cancel = True
Else
End If
End Sub

Private Sub tbDosyaNo_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If Trim(tbDosyaNo.Value) = "" And Me.Visible Then
    MsgBox "Dosya numarasını boş bırakmayınız", vbCritical, "Hata"
    Cancel = True
    End If
End Sub

Private Sub tbDosyaNo_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    Select Case KeyAscii
        Case 46
            If InStr(1, tbDosyaNo, ".") > 0 Then KeyAscii = 0
        Case 48 To 57
        Case Else
            KeyAscii = 0
    End Select
End Sub

Private Sub tbSoyad_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If Trim(tbSoyad.Value) = "" And Me.Visible Then
    MsgBox "Hastanın soyadı giriniz", vbCritical, "Hata"
    Cancel = True
Else
End If
End Sub

Private Sub tbCEP1_Change()
tbCEP1.MaxLength = 11
End Sub
Private Sub tbCEP2_Change()
tbCEP2.MaxLength = 11
End Sub
Private Sub tbDOGUMT_Change()
tbDOGUMT.MaxLength = 4
End Sub
Private Sub tbAd_Change()
tbAD.Text = UCase(tbAD.Text)
tbDosyaAdi.Value = tbDosyaNo.Text & "_" & tbAD.Text & "_" & tbSoyad.Text & "_" & CMBtakibi.Text
End Sub

Private Sub tbDosyaNo_Change()
tbDosyaAdi.Value = tbDosyaNo.Text & "_" & tbAD.Text & "_" & tbSoyad.Text & "_" & CMBtakibi.Text
End Sub

Private Sub tbGONDEREN_Change()
tbGONDEREN.Text = UCase(tbGONDEREN.Text)
End Sub

Private Sub tbSoyad_Change()
tbSoyad.Text = UCase(tbSoyad.Text)
tbDosyaAdi.Value = tbDosyaNo.Text & "_" & tbAD.Text & "_" & tbSoyad.Text & "_" & CMBtakibi.Text
End Sub
Private Sub tbTCK_Change()
tbTCK.MaxLength = 11
End Sub
Private Sub tbAD_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    If KeyAscii = 32 Then KeyAscii = 95
End Sub
Private Sub tbSoyad_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    If KeyAscii = 32 Then KeyAscii = 95
End Sub
Private Sub tbTCK_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    If KeyAscii = 32 Then KeyAscii = 0
End Sub

Private Sub tbCEP1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    If KeyAscii = 32 Then KeyAscii = 0
End Sub
Private Sub tbCEP2_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    If KeyAscii = 32 Then KeyAscii = 0
End Sub
Private Sub tbDOGUMT_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    If KeyAscii = 32 Then KeyAscii = 0
End Sub
Private Sub UserForm_Activate()

End Sub
Private Sub UserForm_Initialize()
'sabit liste kullanma nedenim kopyalama esnasinda listeleri karistirmasi

With Me.CMBturu
    .AddItem "NET"
    .AddItem "Papiller_Tiroit_CA"
    .AddItem "Prostat_CA"
    .AddItem "Y90_HCC-KOLANJIO"
    .AddItem "Y90_METASTATIK"
End With

With Me.CMBtakibi
    .AddItem "TRT"
    .AddItem "HS"
    .AddItem "SS"
    .AddItem "LK"
End With

End Sub

 

[seckinb]

merhaba tekrardan
bir fikri olan var mı?

 

[Korhan Ayhan]

Bu tarz sorunun kaynağının tespiti için örnek dosya faydalı olacaktır.

 

[seckinb]

Kullandığım dosyam

 

[Korhan Ayhan]

"kaydetkapa" isimli prosedürü aşağıdaki gibi değiştirip deneyiniz.

Sub kaydetkapa()
    ThisWorkbook.Save
    If Excel.Windows.Count = 1 Then
        Application.Quit
    Else
        ThisWorkbook.Close
    End If
End Sub

 

[seckinb]

Elinize sağlık