otomatik hücre içini boşaltma

[uurc1]

Sayfa 1 de yer alan $A$19:$F$900 aralığındaki verileri makro yardımıyla excel i her kapattığımda otamatik olarak silmesini istiyorum.
Araştırma yaptım ama bulamadım yardım ederseniz sevinirim.
şimdiden teşekkür ederim.
Saygılarımla.

 

[Murat OSMA]

Sayfa adını kendinize göre değiştirip bu kodu ThisWorkbook (BuÇalışmaKitabı) kod kısmına yapıştırabilirsiniz. ​

[FONT="Trebuchet MS"][SIZE="2"]Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Sheets("[COLOR="Red"]Sayfa1[/COLOR]").Range("[COLOR="red"]A19:F900[/COLOR]").ClearContents
End Sub[/SIZE][/FONT]

 

[uurc1]

Sayfa adını kendinize göre değiştirip bu kodu ThisWorkbook (BuÇalışmaKitabı) kod kısmına yapıştırabilirsiniz. ​

[FONT="Trebuchet MS"][SIZE="2"]Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Sheets("[COLOR="Red"]Sayfa1[/COLOR]").Range("[COLOR="red"]A19:F900[/COLOR]").ClearContents
End Sub[/SIZE][/FONT]

Hocam uğraşınız için teşekkür ederim.

Aynı zamanda otamatik kaydetme kodu da kullanıyorum bu koddan dolayı veya kullandığım diğer bu makrolardan kaynaklı olabilir ama çalışmadı tekrar bakabilirseniz sevinirim
iyi çalışmalar.

Sadece otamatik kayıt ThisWorkbook kısmında diğer kodlar modüllerde yer alıyor.

oamatik kaydetme kodu

Private Sub Workbook_BeforeClose(Cancel As Boolean)
ThisWorkbook.Save
MsgBox ("Makro çalıştı.dosya kayıt edildi")
End Sub

Sayıyı yazıya çevirme kodu

Function tl_yaz(sayi)
On Error Resume Next
Dim deg(3), s(3), deger(2)
a = Array("", "bir", "iki", "üç", "dört", "beş", "altı", "yedi", "sekiz", "dokuz")
b = Array("", "on", "yirmi", "otuz", "kırk", "elli", "altmış", "yetmiş", "seksen", "doksan")
C = Array("", "", "bin", "milyon", "milyar", "trilyon")
deger(1) = Int(sayi)
deger(2) = Round(sayi - deger(1), 2) * 100
If sayi = 0 Then son = "sıfır"
For g = 1 To 2
yazi = deger(g)
For d = 1 To Len(yazi) Step 3
e = e + 1
deg(1) = Mid(yazi, Len(yazi) - d - 1, 1)
deg(2) = Mid(yazi, Len(yazi) - d, 1)
deg(3) = Mid(yazi, Len(yazi) - d + 1, 1)
If deg(1) <> 0 Then s(1) = Replace(a(deg(1)) & "yüz", "biryüz", "yüz")
s(2) = b(deg(2))
s(3) = a(deg(3)) & C(e)
If deg(1) + deg(2) + deg(3) = 0 Then s(3) = ""
son = s(1) & s(2) & s(3) & son
If Left(son, 6) = "birbin" Then son = Replace(son, "birbin", "bin")
For f = 1 To 3
deg(f) = ""
s(f) = ""
Next: Next
If g = 1 And deger(1) <> 0 Then tl = son & " TL"
If g = 2 And deger(2) <> 0 Then kr = " " & son & " Kuruş"
son = ""
e = 0
Next
tl_yaz = tl & kr
End Function

veriyi başka sayfaya aktarma kodu

Sub Aktar()
Dim a As Worksheet: Set a = Sheets("Sayfa2")
Dim l As Worksheet: Set l = Sheets("Sayfa1")
If a.Cells(94, 2) = "" Or a.Cells(103, 6) = "" Or a.Cells(95, 2) = "" Then
    MsgBox "TÜM ALANLAR DOLDURULMADAN KAYIT YAPILAMAZ.": Exit Sub
End If
satır = l.[A65536].End(3).Row + 1
    l.Cells(satır, 1) = satır - 16
    l.Cells(satır, 2) = a.Cells(94, 2): l.Cells(satır, 3) = a.Cells(102, 6)
    l.Cells(satır, 4) = a.Cells(103, 6): l.Cells(satır, 5) = a.Cells(95, 2)
    l.Cells(satır, 6) = a.Cells(97, 11):
    Call AKTAR
End Sub

Yazdır kodu

Sub Yazdir()
    Dim Satir As Long, S1 As Worksheet
    Set S1 = Sheets("Sayfa1")
    On Error Resume Next
    Satir = S1.Range("A:F").Find("*", , , , xlByRows, xlPrevious).Row
    On Error GoTo 0
    If Satir > 0 Then
        S1.PageSetup.PrintArea = "$A$2:$F$" & Satir
        S1.PrintOut
    Else
        MsgBox "Sayfada yazdırılacak veri bulunamadı!", vbExclamation
    End If
End Sub

 

[Murat OSMA]

Bu satırı Sheets("Sayfa1").Range("A19:F900").ClearContents
ThisWorkbook.Save satırının üzerine yazın.​

 

[uurc1]

Bu satırı Sheets("Sayfa1").Range("A19:F900").ClearContents
ThisWorkbook.Save satırının üzerine yazın.​

Hocam Çok teşekkür ederim elinize sağlık gayet güzel çalıştı.

 

[Murat OSMA]

Rica ederim, iyi günler.​