Makroda Değişiklik

[Metin55]

İyi günler;
Ekteki dosyada kayıt butonuna bastığımda veriler ebat listesi sayfasına aktarılıyor.Ayrıca dosya c5 hücresindeki isimle "d" klasörü içerisine kayıt yapılıyor.Benim yapmak istediğim d klasörüne kayıt yapılırken a,b,c,sayfalarının silinerek sadece sayfa1(M³) ve Ebat listesi sayfası ile birlikte kayıt yapılabilmesidir. Üzerinde işlem yaptığım dosyadaki sayfaların tümü kalacak sadece yeni kayıt yapılan dosyadaki silinmesini istediğim sayfalar silinecek diğer sayfalar kalacak(sayfa1(M³) ve Ebat listesi).Yardımlarınız için şimdiden teşekkür ederim.

Private Sub CommandButton2_Click()
Sheets("EBAT LİSTELERİ").Unprotect 1978
Application.ScreenUpdating = False

'-------------------eklenen kod----------------------

Set s2 = Sheets("Sayfa1(M³)")
Set s1 = Sheets("ebat listeleri")
Set flk = CreateObject("Scripting.FileSystemObject")
uzanti = flk.GetExtensionName(dosya) ' uzantı buluyor
dosya2 = s2.Range("C5").Value & "" ' dosyanın kendisi"
klasor = "D:\"
Dosya_adi = InputBox("DOSYANIN ADINI DEĞİŞTİREBİLİRSİNİZ.", "UYARI!", dosya2)
If Dosya_adi = "" Then MsgBox "DOSYA ADINI YAZMADINIZ.": Exit Sub
Kayıt_Yeri = klasor & "\" & Dosya_adi & "." & uzanti
If CreateObject("Scripting.FileSystemObject").FileExists(Kayıt_Yeri) = True Then
MsgBox " Bu isimde bir dosya var": Exit Sub
Else
ActiveWorkbook.Save
If flk.FolderExists(klasor) = False Then
MkDir klasor
End If
flk.CopyFile ThisWorkbook.FullName, Kayıt_Yeri
MsgBox "DOSYANIZ AŞAĞIDAKİ İSİMLE KAYIT YAPILMIŞTIR." & Chr(10) & Chr(10) & Kayıt_Yeri, vbInformation, "U Y A R I "
End If
Son_Dolu_Satir = s1.Range("D65536").End(xlUp).Row
    Bos_Satir = Son_Dolu_Satir + 1
   s1.Range("c" & Bos_Satir).Value = _
                   Application.WorksheetFunction.Max(s1.Range("c:c")) + 1
    
    s1.Range("D" & Bos_Satir).Value = s2.[C1]
    s1.Range("E" & Bos_Satir).Value = s2.[C5]
    s1.Range("F" & Bos_Satir).Value = s2.[N4]
    s1.Range("G" & Bos_Satir).Value = s2.[V2]
    s1.Range("H" & Bos_Satir).Value = s2.[V3]
    s1.Range("J" & Bos_Satir).Value = s2.[P64]

Application.EnableEvents = False
dosya = ActiveWorkbook.Name


Application.ScreenUpdating = True
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox Range("C5") & "  NUMARALI İSTİF EBAT LİSTESİ KAYIT DEFTERİNE AKRARILDI", vbInformation
Sheets("EBAT LİSTELERİ").Select
Application.Wait Now + TimeValue("00:00:01")

Sheets("Sayfa1(M³)").Select
Sheets("EBAT LİSTELERİ").Protect 1978

End Sub

 

[Metin55]

Arkadaşlar 1.nolu mesajimdaki makroya yardımcı olabilir misiniz .

 

[Metin55]

Arkadaslar 1nolu mesajimdaki makroda değişiklik yapmak istiyorum.Yardimci olurmusunuz

 

[Murat OSMA]

Uzantı ile başlayan satırı silin ve alttaki kodu bulup uzantı yazan yeri bu şekilde değiştirin;

Kayıt_Yeri = klasor & "\" & Dosya_adi & "." & ".xls"

Kodların sonuna da şu kodları ilave edin;

Application.ScreenUpdating = False
Set ac = Workbooks.Open(klasor & "\" & Dosya_adi & "." & "xls")
Application.DisplayAlerts = False
Sheets(Array("A", "B", "C")).Delete
ac.Close True
Application.ScreenUpdating = True