Makro ile boş hücrelere sıfır yazdırılması gerekiyor.

[s.savas]

Merhaba arkadaşlar.
Ekteki program 31 Aralık tarihinde stok devri yapacak şekilde, sitemizin değerli uzmanlarının katkılarıyla tasarlandı.
İki konuda yardımlarınıza ihtiyacım var.

1.
Aşağıdaki kod ile stok devri yapıyorum

Private Sub Image1_Click()
UserForm1.Hide

Dim saat1 As Date
Dim saat2 As Date
Dim su
saat1 = DateSerial(Year(Date), 12, 31)
saat2 = Date
If saat2 < saat1 Then
su = MsgBox("31 Aralık'tan  Önce Yeni Dönem Oluşturamazsınız.", vbInformation + vbOKOnly _
, "SÜRE BİLDİRİMİ * s.s *")
UserForm1.Show
Exit Sub

ElseIf saat1 = saat2 Then
If MsgBox("Stok devri yapılarak yeni dönem açılacak. Programla ilgili sorunlarınız için e-posta gönderiniz veya arayıınız!" & vbLf & vbLf & "e-posta: s_savas_@hotmail.com, Tel: 0506 xxx xx xx", vbInformation + vbYesNo _
, "..::DİKKAT::.. * s.s *") = vbNo Then UserForm1.Show

Kopyala
sil
Farklı_Kaydet
UserForm1.Show
Exit Sub
End If
End Sub

Ancak vbInformation + vbYesNo _ prosedürü ile çalıştırılan evet/hayır butonlarından hayır seçilirse ilgili makroların çalışması durdurulup userform1 in çalışması gerekirken makrolar çalışmaya devam ediyor.

2.
Aşağıdaki kopyala makrosu ile de Aralık sekmesindeki ilgili sütunlar Ocak sekmesindeki ilgili sütunlara kopyalanıyor.
Bu makroda da; Aralık sekmesindeki AO sütunu Ocak sekmesindeki E sütununa kopyalanırken AO sütundaki boş hücreler E sütununa boş olarak kopyalanıyor.
Burada kopyalama işlemi sırasında Aralık sekmesinde AO sütunundaki boş hücreler Ocak sekmesindeki E sütununa kopyalanırken boş hücrelerin değeri rakamla sıfır (0) yazacak şekilde tanımlanabilirmi.

Sub Kopyala()
    Set s1 = Sheets("Aralık")
    Set s2 = Sheets("Ocak")
    s2.Range("B6:D65536").ClearContents
        
    son = s1.Cells(Rows.Count, "C").End(xlUp).Row
    s1.Range("B6:D" & son).Copy
    s2.[B6].PasteSpecial
               
    son = s1.Cells(Rows.Count, "AO").End(xlUp).Row
    s1.Range("AO6:AO" & son).Copy
    s2.[E6].PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
       
    Application.CutCopyMode = 0
    Set s1 = Nothing
    Set s2 = Nothing
    
End Sub

 

[Huseyinkis]

1.ci işlem için ekli kodları denermisiniz. dosyanızda şifre olduğu için dosyayı açamadım..

Private Sub Image1_Click()
UserForm1.Hide

Dim saat1 As Date
Dim saat2 As Date
Dim su
saat1 = DateSerial(Year(Date), 12, 31)
saat2 = Date
If saat2 < saat1 Then
su = MsgBox("31 Aralık'tan  Önce Yeni Dönem Oluşturamazsınız.", vbInformation + vbOKOnly _
, "SÜRE BİLDİRİMİ * s.s *")
UserForm1.Show
Exit Sub

ElseIf saat1 = saat2 Then
If MsgBox("Stok devri yapılarak yeni dönem açılacak. Programla ilgili sorunlarınız için e-posta gönderiniz veya arayıınız!" & vbLf & vbLf & "e-posta: s_savas_@hotmail.com, Tel: 0506 xxx xx xx", vbInformation + vbYesNo _
, "..::DİKKAT::.. * s.s *") = vbNo Then UserForm1.Show
[B]else[/B]
Kopyala
sil
Farklı_Kaydet
UserForm1.Show
End If
end if
End Sub

 

[s.savas]

1.ci işlem için ekli kodları denermisiniz. dosyanızda şifre olduğu için dosyayı açamadım..

Private Sub Image1_Click()
UserForm1.Hide

Dim saat1 As Date
Dim saat2 As Date
Dim su
saat1 = DateSerial(Year(Date), 12, 31)
saat2 = Date
If saat2 < saat1 Then
su = MsgBox("31 Aralık'tan  Önce Yeni Dönem Oluşturamazsınız.", vbInformation + vbOKOnly _
, "SÜRE BİLDİRİMİ * s.s *")
UserForm1.Show
Exit Sub

ElseIf saat1 = saat2 Then
If MsgBox("Stok devri yapılarak yeni dönem açılacak. Programla ilgili sorunlarınız için e-posta gönderiniz veya arayıınız!" & vbLf & vbLf & "e-posta: s_savas_@hotmail.com, Tel: 0506 xxx xx xx", vbInformation + vbYesNo _
, "..::DİKKAT::.. * s.s *") = vbNo Then UserForm1.Show
[B]else[/B]
Kopyala
sil
Farklı_Kaydet
UserForm1.Show
End If
end if
End Sub

Arkadaşım kusura bakmayın. İmleç excell butonuna geldiği zaman şifreyi gösteriyor bu yüzden şifreyi ayrıca yazmamıştım. Dosyanın şifresi:1234
Düzenlediğiniz kod ile hayır seçilirse userform1 çalışarak makroların çalışması durduruluyor ancak evet seçilirse de program kapanıyor (excel komple kapanıyor). Birdaha bakarsanız memnun olurum.

 

[Huseyinkis]

Ekteki dosyayı incelermisin...

Hata varsa tekrar bakalım..

 

[Orion1]

Kendi dosyanıza uyarlayınız.

On Error Resume Next
Range("A1:E100").SpecialCells(xlCellTypeBlanks) = 0
On Error GoTo 0

 

[s.savas]

Kendi dosyanıza uyarlayınız.

On Error Resume Next
Range("A1:E100").SpecialCells(xlCellTypeBlanks) = 0
On Error GoTo 0

Ekteki dosyayı incelermisin...

Hata varsa tekrar bakalım..

Arkadaşlar her ikinize de teşekkür ederim. Sorun çözülmüştür.