Hücre boş ise Dosya kaydetmesin

[tsoyts]

Arkadaşlar herkese kolay gelsin. Her gün düzenli tuttuğumuz bir tablomuz var ve her sayfa diğerinin aynısı olacak şekilde sadece sayfa isimleri 01.01.2020-02.01.2020 devam ediyor. Bazen arkadaşlar değer girmeyi unutuyor. Bu sorunu ortadan kaldırmak için Tabloda ki A3:AK33 arasında boş hücre varsa dosyayı kaydetmek istediklerinde hata ile karşılaşsınlar istiyorum.

Birde a3 hücresinden a33 hücresine kadar ardışık her değer bir önceki değerin %+-10 sınırını aşıyorsa msgbox da girilen değeri kontrol ediniz gibi bir uyarı vermesini istiyorum.

Kodlar tüm çalışma kitabını kapsamalı sayfa bazlı olmaması gerekiyor. vba da bu işlemleri hangi kodlarla yapabilirim.

Yardımlarınızı beklemekteyim. Şimdiden ilginize teşekkür ediyorum.

 

[Muzaffer Ali]

Merhaba.

Dosyanızı kod kısmını açın (ALT+F11)
"BuÇaşışmaKitabı(ThisWorkBook)" adlı kod editörünü açın aşağıdaki kodları yapıştırın.

Option Explicit

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim syf As Worksheet
    Dim BakBos As Range
    Dim BakDeger As Range
    Dim Fark
    For Each syf In ThisWorkbook.Worksheets
        For Each BakBos In syf.Range("A3:AK33")
            If BakBos = "" Then
                MsgBox "'" & syf.Name & "' adlı sayfanın '" & BakBos.Address & "' hücresi boş. Lütfen hücreyi boş bırakmayınız.", vbExclamation, "Kayıt gerçekleştirilemedi"
                Cancel = True
                Exit Sub
            End If
        Next
        For Each BakDeger In syf.Range("A3:A32")
            Fark = BakDeger - BakDeger(2, 1)
            Fark = Fark / (BakDeger / 100)
            If Fark > 10 Or Fark < (-10) Then
                MsgBox "'" & syf.Name & "' adlı sayfanın '" & BakDeger.Address & "' hücresi ile '" & BakDeger(2, 1).Address & "' hücresi arasındaki fark %10'dan fazla. Lütfen kontrol ettikten sonra yeniden deneyiniz.", vbExclamation, "Kayıt gerçekleştirilemedi"
                Cancel = True
                Exit Sub
            End If
        Next
    Next
End Sub

 

[tsoyts]

Cevabınız için çok teşekkür ediyorum uyguladım ve çok güzel oldu. Bir ricada daha bulunabilirsem eğer zamanınız olursa ikinci seçenek için yani %10 sınırlarını aştığında kaydet dediğimde sadece uyarı verip mesela : %10 sınırı aşıldı yinede kaydetmek istiyor musunuz diye seçenek çıkıp evet dendiğinde kaydedilse hayır dediğinde kontrol edilse. Böyle birşey mümkün müdür ?

 

[mstfsngn]

Makro ile PDF olarak kaydetmek istediğim sayfanın ismini c11 hücresindeki isimle, e1 hücresindeki tarihten oluştursun istiyorum aşağıda paylaşıyorum bunun üzerinde nasıl değişiklik yapmalıyım ? Şimdiden teşekkür ederim..
Sub PdfEkle()
'
' PdfEkle Makro
'

'
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Users\MAVİ-ÇELİK\Desktop\TEKLİFLER\STOK GİRME .pdf", Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
End Sub

 

[tsoyts]

birde " Fark = BakDeger - BakDeger(2, 1) " bu değer 0 a eşit olduğunda hata veriyor

 

[Muzaffer Ali]

1-Bir hücredeki değer 0 ve sonrakinde de 0 ise ne olsun.
2-Bir hücredeki değer 5 ve sonrakinde 0 ise ne olsun.
3-Bir hücredeki değer 0 ve sonrakinde 5 ise ne olsun.
4-Bir hücredeki değer 0 ve sonrakinde 20 ise ne olsun.

 

[Muzaffer Ali]

Şimdi tekrar kontrol edin.

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim syf As Worksheet
    Dim BakBos As Range
    Dim BakDeger As Range
    Dim Fark
    Dim Bolunen
    For Each syf In ThisWorkbook.Worksheets
        For Each BakBos In syf.Range("A3:AK33")
            If BakBos = "" Then
                MsgBox "'" & syf.Name & "' adlı sayfanın '" & BakBos.Address & "' hücresi boş. Lütfen hücreyi boş bırakmayınız.", vbExclamation, "Kayıt Gerçekleştirilemedi"
                Cancel = True
                Exit Sub
            End If
        Next
        For Each BakDeger In syf.Range("A3:A32")
            
            If BakDeger = 0 And BakDeger(2, 1) = 0 Then
            
            Else
                Bolunen = BakDeger
                If Bolunen = 0 Then Bolunen = BakDeger(2, 1)
                
                Fark = BakDeger - BakDeger(2, 1)
                Fark = Fark / (Bolunen / 100)
                
                If Fark > 10 Or Fark < (-10) Then
                    If MsgBox("'" & syf.Name & "' adlı sayfanın '" & BakDeger.Address & "' hücresi ile '" & BakDeger(2, 1).Address & "' hücresi arasındaki fark %10'dan fazla. Yine de kaydetmek istiyoor musunuz?", vbExclamation + vbYesNo, "Kayıt Yapılsın mı?") = vbNo Then
                        Cancel = True
                        Exit Sub
                    End If
                End If
            End If
        Next
    Next
End Sub

 

[tsoyts]

Şimdi tekrar kontrol edin.

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim syf As Worksheet
    Dim BakBos As Range
    Dim BakDeger As Range
    Dim Fark
    Dim Bolunen
    For Each syf In ThisWorkbook.Worksheets
        For Each BakBos In syf.Range("A3:AK33")
            If BakBos = "" Then
                MsgBox "'" & syf.Name & "' adlı sayfanın '" & BakBos.Address & "' hücresi boş. Lütfen hücreyi boş bırakmayınız.", vbExclamation, "Kayıt Gerçekleştirilemedi"
                Cancel = True
                Exit Sub
            End If
        Next
        For Each BakDeger In syf.Range("A3:A32")
           
            If BakDeger = 0 And BakDeger(2, 1) = 0 Then
           
            Else
                Bolunen = BakDeger
                If Bolunen = 0 Then Bolunen = BakDeger(2, 1)
               
                Fark = BakDeger - BakDeger(2, 1)
                Fark = Fark / (Bolunen / 100)
               
                If Fark > 10 Or Fark < (-10) Then
                    If MsgBox("'" & syf.Name & "' adlı sayfanın '" & BakDeger.Address & "' hücresi ile '" & BakDeger(2, 1).Address & "' hücresi arasındaki fark %10'dan fazla. Yine de kaydetmek istiyoor musunuz?", vbExclamation + vbYesNo, "Kayıt Yapılsın mı?") = vbNo Then
                        Cancel = True
                        Exit Sub
                    End If
                End If
            End If
        Next
    Next
End Sub

Çok çok teşekkür ederim ellerinize sağlık. Kendi tablolarıma uyarlıyorum. Kusura bakmayın bilgisayar başına geçemedim cevap veremedim. Hakkınızı helal edin.