Kapalı Çalışma Kitabından belli çalışma sayfalarını silme

[hsayar]

Kapalı Çalışma Kitabından belli çalışma sayfalarını silme

Sub AktKit_KrnmynSf_Sil()
[color="red"]'sadece koru01, 2,3,4,5 bu kitapta kalır[/color]

Set s1 = Sheets("koru01"): Set s2 = Sheets("koru02")
Set s3 = Sheets("koru03"): Set s2 = Sheets("koru04")
Set s2 = Sheets("koru05")
cs_kr1 = "koru01": cs_kr2 = "koru02": cs_kr3 = "koru03": cs_kr4 = "koru04": cs_kr5 = "koru05"

'---------------------
'Örnek Dosyasında sonradan oluşturlan dosyaları siler
 'korunacak dosyaları başa taşı
    Sheets("koru01").Move Before:=Sheets(1)
    Sheets("koru02").Move Before:=Sheets(2)
    Sheets("koru03").Move Before:=Sheets(3)
    Sheets("koru04").Move Before:=Sheets(4)
    Sheets("koru05").Move Before:=Sheets(5)

For i = Sheets.Count To 1 Step -1     'For i = 1 To Sheets.Count
    If Sheets(i).Name <> cs_kr1 And Sheets(i).Name <> cs_kr2 And _
       Sheets(i).Name <> cs_kr3 And Sheets(i).Name <> cs_kr4 And _
       Sheets(i).Name <> cs_kr5 Then
          Application.DisplayAlerts = False
          Sheets(i).Delete
          Application.DisplayAlerts = True
       Else
          Set s1 = Nothing: Set s2 = Nothing: Set s3 = Nothing:  Set s4 = Nothing: Set s5 = Nothing: Exit Sub
    End If
Next i
    MsgBox "Ar&#351;ivlenen dosyadan, " & vbCr & _
    cs_kr1 & " / " & cs_kr2 & " / " & vbCr & _
    cs_kr3 & " / " & cs_kr4 & " / " & vbCr & _
    cs_kr5 & vbCr & " &#231;al&#305;&#351;ma sayfalar&#305; silinmi&#351;tir.", _
    vbInformation, vbInformation, "B&#304;LG&#304;-01"
End Sub
'************************************/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/
'************************************/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/

Sub AktKit_KrnnSf_Sil()
[color="red"]'koru01, 2,3,4,5 dışındaki sayfalar bu kitapta kalır[/color]

Dim TargetFolder As String
Dim s1 As Worksheet ', s2 As Worksheet, s3 As Worksheet
Set s1 = Sheets("koru01"): Set s2 = Sheets("koru02")
Set s3 = Sheets("koru03"): Set s2 = Sheets("koru04")
Set s2 = Sheets("koru05")

'Taslak Sayfalar
cs_kr1 = "koru01": cs_kr2 = "koru02": cs_kr3 = "koru03": cs_kr4 = "koru04": cs_kr5 = "koru05"
'---------------------
'Örnek Dosyasında sonradan oluşturlan dosyaları siler
 'korunmacak dosyaları sona taşı
    sn = Sheets.Count
    Sheets("koru01").Move After:=Sheets(sn)
    Sheets("koru02").Move After:=Sheets(sn)
    Sheets("koru03").Move After:=Sheets(sn)
    Sheets("koru04").Move After:=Sheets(sn)
    Sheets("koru05").Move After:=Sheets(sn)

For i = Sheets.Count To 1 Step -1     'For i = 1 To Sheets.Count
    If Sheets(i).Name = cs_kr1 Then
          Application.DisplayAlerts = False: Sheets(i).Delete: Application.DisplayAlerts = True
    ElseIf Sheets(i).Name = cs_kr2 Then
          Application.DisplayAlerts = False: Sheets(i).Delete: Application.DisplayAlerts = True
    ElseIf Sheets(i).Name = cs_kr3 Then
          Application.DisplayAlerts = False: Sheets(i).Delete: Application.DisplayAlerts = True
    ElseIf Sheets(i).Name = cs_kr4 Then
          Application.DisplayAlerts = False: Sheets(i).Delete: Application.DisplayAlerts = True
    ElseIf Sheets(i).Name = cs_kr5 Then
          Application.DisplayAlerts = False: Sheets(i).Delete: Application.DisplayAlerts = True
    Else
          Set s1 = Nothing: Set s2 = Nothing: Set s3 = Nothing:  Set s4 = Nothing: Set s5 = Nothing: Exit Sub
    End If
Next i
End Sub
'************************************/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/
'************************************/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/

Yukarıdaki kodlar Aktif çalışma kitabında çalışıyor.....

Ancak Kapalı olan c:\test\aaa.xls ye makro yazmadan ben bu işlemleri nasıl yaparım?
özellikle ikinci kod olan 'koru01, 2,3,4,5 dışındaki sayfalar bu kitapta kalır işlemi....




Uğraşa uğraşa kendi sorumun bir parçasını yanıtladım, burdan öte bilgim yetmiyor...

LÜTFEN YARDIM EDİN

 

[hsayar]

lütfen yardımlarınızı esirgemeyin şunu yanlış anlattın deyin yada imkansız deyin bir şey söyleyin...

İstediğim çok basit bir çalışma kitabı oluşturun 10,15 tane çalışa sayfası oluşturun.... 5 tanesinin adlarını koru01,koru02,koru03,koru04,koru 05 olarak düzenleyin kaydedin.

kodları modüle1 kopyalayın...
Ayrı ayrı deneyin....
1. kod çalıştığında koru01,koru02,koru03,koru04,koru 05 haricindeki çalışma sayfaları çalışma kitabınızdan silinmiş olacak
2. kod çalıştığında koru01,koru02,koru03,koru04,koru 05 çalışma sayfaları çalışma kitabınızdan silinmiş olacak

benim istediğim ikinci kodun benim belirttiğim dizindeki ve benim belrttiği addaki çalışma kitabını açması işlemi yapması ve açtığ çalışma kitabını kaydedip, kapatması

 

[Recep İpek]

Aşağıdaki kodları deneyebilirmisiniz?

C sürücüsündeki Deneme klasöründeki kapalı deneme çalışma kitabının deneme1,deneme2,deneme3,deneme4 sayfalarını siler..

Sub SayfaSil()
Dim silinecek()
    Application.ScreenUpdating = False
    silinecek = Array("deneme1", "deneme2", "deneme3", "deneme4")
    Set xlBook = Workbooks.Open("C:\deneme\deneme.xls")
        For Each sira In silinecek
            For Each sayfa In xlBook.Worksheets
                If sira = sayfa.Name Then
                    Application.DisplayAlerts = False
                        sayfa.Delete
                    Application.DisplayAlerts = True
                End If
            Next
        Next
        xlBook.Save
        xlBook.Close
    Application.ScreenUpdating = True
    Set xlBook = Nothing
    Msgbox "Bitti"
End Sub

 

[hsayar]

Sayın Ripek ilginize teşekkür ederim öğrenmek için bir iki soruma cevap verirseniz sevinirim

silinecek = Array("deneme1", "deneme2", "deneme3", "deneme4")

içinde istediğimiz kadar veri tanımlayabilirmiyiz?

For Each sira In silinecek
For Each sayfa In xlBook.Worksheets
If sira = sayfa.Name Then

satırlarının açıklamsı nedir
For each ın uygulama alnaları nerelei olabili başka


birde hatala project explorerdaki dockable yi kaldırdım sayfada ya kodaları ya proje gezgini görüyorum eski hali,ne nasıl getirecem
Saygılaımla

 

[Recep İpek]

silinecek = Array("deneme1", "deneme2", "deneme3", "deneme4")

Tanımlayabilirsiniz.

For Each sira In silinecek 'silinecek dizisindeki verileri sıra ile sira değişkenine atar
For Each sayfa In xlBook.Worksheets 'aynı şekilde çalışma kitabındaki sayfaları sıra ile sayfa değişkenine atar
If sira = sayfa.Name Then Eğer sira ile sayfa adi aynı ise sayfa silinir.

Forumda For Each şeklinde arama yaptırırsanız bununla ilgili birçok örnek bulabilirsiniz.

 

[Mahmut Kök]

Hocam, sayın Ripek istediğiniz şekilde bir kod hazırlamış; ancak sayfa silmek yerine, istenen sayfaların taşınmasıyla ilgili bir örnek hazırlamıştım; ama birkaç nedenden dolayı bu şekildeki kodların uygun olmayacağını söylemiştiniz. Eğer korunacak sayfaların isimleri sabitse, yani belirttiğiniz şekilde Koru01, Koru02, Koru03... gibi ise yine bahsettiğim şekilde bir kod kullanabilirsiniz.

Aşağıdaki kodları çalıştırdığınızda, Koru01, Koru02... dışındaki bütün sayfalar, A1 hücresindeki tarihin ay ve yılıyla oluşturulmuş başka bir çalışma kitabına taşınır. Kodları çalıştırdığınız çalışma kitabında ise Koru01, Koru02... dışında çalışma sayfası kalmaz. Eğer doğru anlamış isem aşağıdaki kodları da deneyebilirsiniz.

Sub farklı()
Application.ScreenUpdating = False
ad = Format(Sheets(1).Range("a1"), "mmyyyy")
bu = ActiveWorkbook.Name
son = Workbooks(bu).Worksheets.Count
If son <= 5 Then 'korunacak 5 sayfa.
MsgBox "TAŞINACAK SAYFA YOK"
Exit Sub
End If
Set yeni = Workbooks.Add
su = yeni.Name
    For syf = 1 To son
    If syf > Workbooks(bu).Worksheets.Count Then GoTo gec
    Set s1 = Workbooks(bu).Sheets(syf)
    ssyf = Workbooks(su).Worksheets.Count
    If s1.Name = "koru01" Or s1.Name = "koru02" Or s1.Name = "koru03" Or s1.Name = "koru04" Or s1.Name = "koru05" Then GoTo atla
    s1.Move After:=Workbooks(su).Sheets(ssyf)
    syf = syf - 1
atla:
    Next
gec:
    Application.DisplayAlerts = False
    Workbooks(su).Sheets("Sayfa1").Delete
    Workbooks(su).Sheets("Sayfa2").Delete
    Workbooks(su).Sheets("Sayfa3").Delete
    Application.DisplayAlerts = True
    
    ActiveWorkbook.SaveAs Filename:="C:\" & ad & ".xls"
    ActiveWindow.Close
    Sheets("koru01").Select
    Range("A1").Select
Application.ScreenUpdating = True
MsgBox "YENİ DOSYANIZ C:\" & ad & ".xls ADIYLA OLUŞTURULDU."
End Sub

 

[hsayar]

mesleki hocam çıkmak zorundayıım şöyle bir inceledimde gözüme hoş geldi çünkü daha sonra geri dönüp asıl dosyadan koru01,02,03, gibi sayfalıan dışındakil eiri silmem gerekiyordu...

If s1.Name = "koru01" Or s1.Name = "koru02" Or s1.Name = "koru03" Or s1.Name = "koru04" Or s1.Name = "koru05" Then GoTo atla
s1.Move After:=Workbooks(su).Sheets(ssyf)

şu kısmı hocamın yazdığı gibi dizi ve for each ile nasıl kullanabilirm.

    silinecek = Array("deneme1", "deneme2", "deneme3", "deneme4")
    Set xlBook = Workbooks.Open("C:\deneme\deneme.xls")
        For Each sira In silinecek
            For Each sayfa In xlBook.Worksheets
                If sira = sayfa.Name Then
                    Application.DisplayAlerts = False
                        sayfa.Delete
                    Application.DisplayAlerts = True
                End If
            Next

Tam yapmak istediğim Hergü çalışan bordro.xls kitabımı ay başında günlük!a1 hücresindeki tarihin
aayyyy formatı ile oluşan ad ile kaydetmek (tamam)
aayyyy.xls den makroları silmek (tamam)
aayyyy.xls den korunan sayfaları silmek (koru01,02,03 vs)
(Bu başlıkta Sn.Ripekin 3.mesajdaki cevabı elverişli)
bordro.xls den korunan sayfa dışındakileri silmek (Bu başlıkta 1. mesajdaki 1.kod uygun)

'''''''''''''''''''''''''''''''''''''''''''
Ama sizin kodlarınız olayı bitirmiş gbi gözüküyor.... yalnız for...earch ile yapabileneciğine inanıyorum hem ben kodu kavrayabilirim, hemde muhtemelen kodlar ve tanımlama işlemleri dahada kısalacaktır.

saygılarımla

 

[hsayar]

Hocam, sayın Ripek istediğiniz şekilde bir kod hazırlamış; ancak sayfa silmek yerine, istenen sayfaların taşınmasıyla ilgili bir örnek hazırlamıştım; ama birkaç nedenden dolayı bu şekildeki kodların uygun olmayacağını söylemiştiniz. Eğer korunacak sayfaların isimleri sabitse, yani belirttiğiniz şekilde Koru01, Koru02, Koru03... gibi ise yine bahsettiğim şekilde bir kod kullanabilirsiniz.

Aşağıdaki kodları çalıştırdığınızda, Koru01, Koru02... dışındaki bütün sayfalar, A1 hücresindeki tarihin ay ve yılıyla oluşturulmuş başka bir çalışma kitabına taşınır. Kodları çalıştırdığınız çalışma kitabında ise Koru01, Koru02... dışında çalışma sayfası kalmaz. Eğer doğru anlamış isem aşağıdaki kodları da deneyebilirsiniz.

Sub farklı()
Application.ScreenUpdating = False
ad = Format(Sheets(1).Range("a1"), "mmyyyy")
bu = ActiveWorkbook.Name
son = Workbooks(bu).Worksheets.Count
If son <= 5 Then 'korunacak 5 sayfa.
MsgBox "TAŞINACAK SAYFA YOK"
Exit Sub
End If
Set yeni = Workbooks.Add
su = yeni.Name
    For syf = 1 To son
    If syf > Workbooks(bu).Worksheets.Count Then GoTo gec
    Set s1 = Workbooks(bu).Sheets(syf)
    ssyf = Workbooks(su).Worksheets.Count
    If s1.Name = "koru01" Or s1.Name = "koru02" Or s1.Name = "koru03" Or s1.Name = "koru04" Or s1.Name = "koru05" Then GoTo atla
    s1.Move After:=Workbooks(su).Sheets(ssyf)
    syf = syf - 1
atla:
    Next
gec:
    Application.DisplayAlerts = False
    Workbooks(su).Sheets("Sayfa1").Delete
    Workbooks(su).Sheets("Sayfa2").Delete
    Workbooks(su).Sheets("Sayfa3").Delete
    Application.DisplayAlerts = True
    
    ActiveWorkbook.SaveAs Filename:="C:\" & ad & ".xls"
    ActiveWindow.Close
    Sheets("koru01").Select
    Range("A1").Select
Application.ScreenUpdating = True
MsgBox "YENİ DOSYANIZ C:\" & ad & ".xls ADIYLA OLUŞTURULDU."
End Sub

Sayın mesleki hocam kodlarınız olduğu gibi iken bende hata verdi aşağıdaki gibi revize ettim;

Sub farklı()
Application.ScreenUpdating = False

bu = ThisWorkbook.Name
Dim Bu_wb As Workbook
Dim Bu_s1 As Worksheet
Bu_Kit_Ad = ThisWorkbook.Name                                               '**bu çalışma kitabını değişkene atama
Set Bu_wb = Workbooks(Bu_Kit_Ad)
Set Bu_s1 = Bu_wb.Sheets("koru01")
Kay_Kit_Ad = Format(Bu_s1.Range("a1"), "mmyyyy")                           '**Bu_s1 in a1 hücresindeki tarihi "aayyyy" formatında değişkene atama

son = Workbooks(bu).Worksheets.Count
If son <= 5 Then 'korunacak 5 sayfa.
MsgBox "TAŞINACAK SAYFA YOK"
Exit Sub
End If

Set yeni = Workbooks.Add
su = yeni.Name
    For syf = 1 To son
    If syf > Workbooks(bu).Worksheets.Count Then GoTo gec
    Set s1 = Workbooks(bu).Sheets(syf)
    ssyf = Workbooks(su).Worksheets.Count
    If s1.Name = "koru01" Or s1.Name = "koru02" Or s1.Name = "koru03" Or s1.Name = "koru04" Or s1.Name = "koru05" Then GoTo atla
    s1.Move After:=Workbooks(su).Sheets(ssyf)
    syf = syf - 1
atla:
    Next
gec:
    Application.DisplayAlerts = False
    Workbooks(su).Sheets("Sayfa1").Delete
    Workbooks(su).Sheets("Sayfa2").Delete
    Workbooks(su).Sheets("Sayfa3").Delete
    Application.DisplayAlerts = True

    Workbooks(su).Activate
    kayd_yol_ad = "C:\" & Kay_Kit_Ad & ".xls"
    Workbooks(su).SaveAs Filename:=kayd_yol_ad
    ActiveWindow.Close
    
    Workbooks(bu).Activate
    Bu_s1.Range("k1").Select
Application.ScreenUpdating = True
MsgBox "YENİ DOSYANIZ C:\" & Kay_Kit_Ad & ".xls ADIYLA OLUŞTURULDU."
End Sub

 

[hsayar]

Hocam Kodlarızı biraz daha geliştirdim.
'Form sayfaları hariç diğer kitapları taşıma işlemi için size
'Bilgisayardan gcc.xls iyi sil için korhan hocama
'yaptığınız değişikleri kaydetmek istiyormusunuz? sorusunu hayır olarak cevaplama için orion2
'Bir arraydaki veri sayısı ? için orion2 ye tekrarr teşekkür ederim
'tekrar teşekkür ederim.

AÇIKLAMA: Bir çalışma kitabından, ismini belirlemiş olduğunuz sayfaların dışındakileri yeni çalılşma kitabını geçici olarak kullanıp belirtmiş olduğunuz adla kaydeder.

Sub Formsayfalarıharictasi()
Application.ScreenUpdating = False
'Genel tanımlama işlemleri
Dim Korunansayfalar()
Korunansayfalar = Array("koru01", "koru02", "koru03", "koru04", "koru05")
Krn_Dzi_vs = UBound(Korunansayfalar) + 1

'Bu kitaba ilişkin tanımlama işlemleri
Dim Bu_wb As Workbook
Dim Bu_s1 As Worksheet
Bu_Kit_Dzn = ThisWorkbook.Path: bu_Kit_Ad = ThisWorkbook.Name       'Bu kitabın dizin ve dosya adını değişkkene alır
Set Bu_wb = Workbooks(bu_Kit_Ad)
Bu_Kit_Ydk_ad = Bu_Kit_Dzn & "\gcc_" & bu_Kit_Ad
Bu_wb.SaveCopyAs Bu_Kit_Ydk_ad
bu_Kit_ss = Bu_wb.Worksheets.Count
Set Bu_s1 = Bu_wb.Sheets("koru01")

'Kaydedilecek kitaba ilişkin tanımlama işlemleri
'kay_dzn_Ad biligsayarınızda var olmalıdır.
Kay_Dzn_Ad = Format(Bu_s1.Range("a1"), "yyyy"): Kay_Kit_Ad = Format(Bu_s1.Range("a1"), "mmyyyy")                           '**Bu_s1 in a1 hücresindeki tarihi "aayyyy" formatında değişkene atama
kay_yol_ad = Bu_Kit_Dzn & "\" & Kay_Dzn_Ad & "\" & Kay_Kit_Ad & ".xls"

'=========== BU KİTAPTAN GEÇİCİ KİTABA TAŞIMA İŞLEMİ
If bu_Kit_ss <= Krn_Dzi_vs Then 'korunacak 5 sayfa.
MsgBox "TA&#350;INACAK SAYFA YOK": Exit Sub
End If

Set yeni = Workbooks.Add
su = yeni.Name
  For syf = 1 To bu_Kit_ss
    If syf > Bu_wb.Worksheets.Count Then GoTo gec
      Set s1 = Bu_wb.Sheets(syf)
      ssyf = Workbooks(su).Worksheets.Count
        If s1.Name = Korunansayfalar(0) Or s1.Name = Korunansayfalar(1) Or _
           s1.Name = Korunansayfalar(2) Or s1.Name = Korunansayfalar(3) Or _
           s1.Name = Korunansayfalar(4) Then GoTo atla
           s1.Move After:=Workbooks(su).Sheets(ssyf)
           syf = syf - 1
atla:
  Next
gec:
 'A&#351;a&#287;&#305;daki kodlar eklenen &#231;al&#305;&#351;ma sayfas&#305;ndan standart sayfalr&#305; siler
           Application.DisplayAlerts = False
           Workbooks(su).Sheets("Sayfa1").Delete
           Workbooks(su).Sheets("Sayfa2").Delete
           Workbooks(su).Sheets("Sayfa3").Delete
           Application.DisplayAlerts = True
  'Ge&#231;ici Kitab&#305; Aktif Et, belrtilen adla kopyala, kaydetmeden kapat
    Workbooks(su).Activate
    Workbooks(su).SaveCopyAs kay_yol_ad
    Workbooks(su).Close False
' bu Kitab&#305; Aktif Et, belirtilen h&#252;cre adrsine d&#246;n
    Bu_wb.Activate
    Bu_s1.Range("k1").Select
Application.ScreenUpdating = True
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> SON SATIRLAR
MsgBox "YEN&#304; DOSYANIZ " & kay_yol_ad & " ADIYLA OLU&#350;TURULDU."
Kill Bu_Kit_Ydk_ad
End Sub