• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

seckinb

seckinb

Katılım
9 Aralık 2018
Mesajlar
363
Excel Vers. ve Dili
Excel 2019 - 32 bit TR
Merhaba

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

Teşekkürler

PHP: 
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
 
merhaba tekrardan
bir fikri olan var mı?
 
Bu tarz sorunun kaynağının tespiti için örnek dosya faydalı olacaktır.
 
"kaydetkapa" isimli prosedürü aşağıdaki gibi değiştirip deneyiniz.

C++: 
Sub kaydetkapa()
    ThisWorkbook.Save
    If Excel.Windows.Count = 1 Then
        Application.Quit
    Else
        ThisWorkbook.Close
    End If
End Sub
 
Elinize sağlık
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst