s1!a1 değeri ile farklı kaydedilen dosyadan makro,form,sf1,sf2,sf3,sf4 lerin silinmes

[hsayar]

Ben çalışma kitabımı a1 hücresindeki tarihin (01/11/2007) mmyyyy formatı ile (112007) farklı kaydedilen çalışma kitabından Sayfa1,sayfa2,sayfa3,sayfa4 adlı çalışma sayfalarını ve Tüm makro ve varsa form vs. silmesi için kodlarımı nasıl revize etmeliyim?
------
Ardından makronun çalıştığı sayfa döndüğünde ondan Sayfa1,sayfa2,sayfa3,sayfa4 HARİCİNDEKİ çalışma sayfalarını silmesi için nasıl kod yazmlıyım?

sayın cost kontolün başka bir başlıkta yazmış olduğu farklı kaydet makrosuna yönlendirdiğimde benden tekrar dosya adı istiyor

Sub FolderExistsArsiv()
Dim TargetFolder As String
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Set s3 = Sheets("Sayfa3")
'Set s4 = Sheets("Sayfa4")
Set fs = CreateObject("Scripting.FileSystemObject")
a = WorksheetFunction.Text(s1.Cells(1, 1), "yyyy")
b = WorksheetFunction.Text(s1.Cells(1, 1), "mmyyyy")
k_yol = ThisWorkbook.Path
k_ad = ThisWorkbook.Name
tarih = s1.Cells(1, 1)

'---------------Yıl
yol = ThisWorkbook.Path & "\" ' mevcut çalışma kitabının olduğu ve alt klasör açılacak yol
TargetFolder = yol & a         ' Açılacak klasör adı ile birleşimi
If Not fs.FolderExists(TargetFolder) Then        'KONTROL
ChDir yol: MkDir a: MsgBox a & " Klasörü oluşturuldu.!"  'klasöre git, oluşturma mesajı ver
GoTo CalismasayfasıKontrol
Else
MsgBox a & " Klasörü var!"   'var mesajı var
End If

'--------------->>>>>>
Exit Sub
CalismasayfasıKontrol:
MsgBox "CalismasayfasıKontrol-e hoşgeldiniz"
'farklı kaydet
    ActiveWorkbook.SaveAs Filename:= _
    yol & a & "\" & b & ".xls", FileFormat:=xlNormal, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
        CreateBackup:=False
        [color=Red]farklıkaydet[/color][color=blue]  denedim, ama tekrar dosya adı sordu[/color]
'Aynı dosyaya Dön
    ChDir k_yol
    Workbooks.Open Filename:= _
        k_yol & "\" & k_ad

'farklı kaydedileni kapat
    ck_adi = b & ".xls": Windows(ck_adi).Close
'...........................
End Sub

Sub farklıkaydet()
    Dim vFilename As Variant
    Dim wbActiveBook As Workbook
    Dim oVBComp As Object
    Dim oVBComps As Object
    
    vFilename = Application.GetSaveAsFilename(filefilter:="Microso ft Excel Workbooks,*.xls", _
    Title:="Save Copy Without Macros")
    If vFilename = False Then Exit Sub
    ActiveWorkbook.SaveCopyAs vFilename
    Set wbActiveBook = Workbooks.Open(vFilename)
    Set VBComps = ActiveWorkbook.VBProject.VBComponents
    For Each VBComp In VBComps
    Select Case VBComp.Type
    Case 100
    With VBComp.CodeModule
    .DeleteLines 1, .CountOfLines
    End With
    Case Else
    VBComps.Remove VBComp
    End Select
    Next VBComp
    Set VBComps = Nothing
End Sub

 

[hsayar]

selam derdimi hala çözenedim yardınlarınızı bekliyorum

 

[hsayar]

Dosya Adını Değişkenden almasını sağladım? devamı nasıl

Sub farklıkaydet()
    Dim vFilename As Variant
    Dim wbActiveBook As Workbook
    Dim oVBComp As Object
    Dim oVBComps As Object
   [color=blue]
    Dim s1 As Worksheet
    Set s1 = Sheets("Sayfa1")
  

      dosya = WorksheetFunction.Text(s1.Range("a1"), "mmyyyy") & "_test"  'sayfa1 a1 tarih ise tarihin aayyyy değeri  ile kaydeder (Duruma göre ' kullanrak isimi değiştebilirisiniz"
    dizin = s1.Range("a2")
    hedefdizin = "c:\TEST\" & dizin & "\"                 'buradaki "xxxxxxxxx" alanını istediğini ile değiştirabilirsiniz
    'ilgili yolun mutlaka olması gerekmektedir makro hata verir


    vFilename = hedefdizin & dosya & ".xls"                'kaydedilecek dosyanın dizini ve adı
[/color]
  
  [color=red]vFilename = Application.GetSaveAsFilename(filefilter:="Microso ft Excel Workbooks,*.xls", _
    Title:="Save Copy Without Macros")        'iletişim penceresi getirir
    If vFilename = False Then Exit Sub          'dosya adı yazmaz veya iptale basarsak işlemi bitirir [/color]

    ActiveWorkbook.SaveCopyAs vFilename                     'dosyayı DEĞŞKEN ADI İLE kopyala
    Set wbActiveBook = Workbooks.Open(vFilename)            'DEĞİŞKEN adlı dosyayı aç
    '>>>>>tahminen makroları silmeye başla
    Set VBComps = ActiveWorkbook.VBProject.VBComponents     'Bilmiyorum01 makroları silme işlemi başlangıcı herhalde
    For Each VBComp In VBComps                              'Bilmiyorum02
    Select Case VBComp.Type                                 'Bilmiyorum03
    Case 100                                                'Bilmiyorum04
    With VBComp.CodeModule                                  'Bilmiyorum05
    .DeleteLines 1, .CountOfLines                           'Bilmiyorum06
    End With                                                'Bilmiyorum07
    Case Else                                               'Bilmiyorum08
    VBComps.Remove VBComp                                   'Bilmiyorum09
    End Select                                              'Bilmiyorum10
    Next VBComp                                             'Bilmiyorum11
    Set VBComps = Nothing                                   'Bilmiyorum makroları silme işlemi bitişi herhalde
    MsgBox "makroları silme işlemi bitti"
    ActiveWorkbook.Save                                     'DEĞİŞKEN adlı dosyayı kaydet
    ActiveWorkbook.Close                                    'DEĞİŞKEN adlı dosyayı kapat

kırmızıları silip, mavileri yapıştırır ve gerekli düzeltmeleri yaparsanız dosyanız istediğiniz sayfanın istediğiniz hücresindeki değer ile kaydedilir.

Aksaklıklar
1) Hedef dizin yoksa mesala "d:\aaa\" içine a2 hücresindeki dizine kaydedeceksen hata verir, oluşturayımmı diye sormaz?
Sorsa ve karşılığında Oluştur, İptal (exit sub) seçenekleri olan kod ilave edilse fena olmaz. Galiba bunu ben halledebilirim.. ilk mesajda örnek vardı.

2) Yalnız böyle bir isimle dosya var diye söylemez?
Söylese Evet değiştir, yeni bir isim vermek istiyorum (inputboxgelse), İptal (exit sub) seçenekleri olan kod ilave edilse fena olmaz.

3) en önemlisi bu;
Asıl Çalışma Kitabımda; Günlük, Tsb,Devirler,Aylık diye çalışma sayfalarım var.

A) Yeni isimle kaydedilen çalışma kitabından bu 4 çalışma sayfasını silecek
B) Asıl Çalışma kitabından bu dört sayfa dışındaki sayfaları silecek

 

[hsayar]

3. mesaj düzenlenmiştir.