Önceki aya ait sayfaları silme kodu yardım

[dumanibo]

Excel dosyasında aşağıdaki gibi bir makro var. Bu makro ile dosya her açıldığında önce PC adını kontrol ediyor. Eğer PC adı "ABC" ise dosyaya yeni bir sayfa ekliyor. Eklediği sayfaya tarihe göre isim veriyor. Eğer yeni bir aya geçildi ise önceki sayfaları siliyor.

Sorun makro yeni aya geçildiğini

If Day(tarihn) = "1" Then

kodu ile ayın 1'i ise anlıyor. Dosya ayın birinde değil de ikisinde açılırsa eski aya ait sayfaları silmiyor. Bu kısmı nasıl düzeltebilirim acaba?




Private Sub Workbook_Open()

Dim tarihn
tarihn = DateAdd("d", 0, Date)
gun = Format(Date, "dd.mmmm")

Application.ScreenUpdating = False

If Environ("COMPUTERNAME") <> "ABC" Then Exit Sub


For a = 1 To Sheets.Count
If UCase(Sheets(a).Name) = UCase(gun) Then Exit Sub
Next

'Ay başında eski sayfaları sil***********************

Application.DisplayAlerts = False 'Uyarıları kapat

If Day(tarihn) = "1" Then 'Ayın 1 ise önceki sayfaları sil
For i = 1 To Worksheets.Count - 1
ActiveWindow.SelectedSheets.Delete
Next
End If
Application.DisplayAlerts = True 'Uyarıları aç

' Ay başında eski sayfaları silme sonu ****************

Worksheets.Add.Move before:=Sheets(1)
ActiveSheet.Name = Date
ActiveWindow.ActiveSheet.Name = gun 'Format(Date, "mmmm yyyy;@")


Exit Sub
Application.ScreenUpdating = True

End Sub

 

[Huseyinkis]

Merhaba ekteki kodları içeler misiniz.

Kodlar dosyayı açtığınızda o güne ait sayfa yoksa onu ekler ve bulunduğunuz ay hariç diğer bütün sayfaları siler.

08 temmuz da açtığınızda 08.Temmuz olarak sayfa yoksa ekler ve Temmuz ayı hariç bütün sayfaları siler.

Private Sub Workbook_Open()

Dim tarihn
tarihn = DateAdd("d", 0, Date)
gun = Format(Date, "dd.mmmm")
ayy = Format(Date, "mmmm")

Application.ScreenUpdating = False

If Environ("COMPUTERNAME") <> "ABC" Then Exit Sub

For a = 1 To Sheets.Count
If UCase(Sheets(a).Name) = UCase(gun) Then yok = 1
Next

If yok = 0 Then Worksheets.Add.Name = gun

'Ay başında eski sayfaları sil***********************

Application.DisplayAlerts = False 'Uyarıları kapat


For i = Worksheets.Count To 1 Step -1
If Mid(Sheets(i).Name, 4, 99) <> ayy Then
Sheets(i).Delete
End If
Next
Application.DisplayAlerts = True 'Uyarıları aç

' Ay başında eski sayfaları silme sonu ****************


Application.ScreenUpdating = True
End Sub

 

[dumanibo]

Teşekkürler sayın Huseyinkis.