- Katılım
- 2 Mart 2005
- Mesajlar
- 2,960
- Excel Vers. ve Dili
-
ev: Ofis 2007- Win Xp
iş: Ofis 2010- Win Vista
Ben denedim başarılı olamadım
Kod:
Sub KitabiYeniDizindeMakrosuz_KrCsolmadanArsivle_CopyAs_ikazver111()
Dim TargetFolder As String 'Klasör kontrolü
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet 'Sayfaların Tanıtılması
Dim s4 As Worksheet, s5 As Worksheet 'Sayfaların Tanıtılması
Dim vFilename As Variant 'Makrosuz Kaydetme ile ilgili
Dim wbActiveBook As Workbook 'Aktif kitap la ilgili galiba
Dim oVBComp As Object 'Makrosuz Kaydetme ile ilgili
Dim oVBComps As Object 'Makrosuz Kaydetme ile ilgili
Dim HdfDznDsy As Variant
Set s1 = Sheets("koru01"): Set s2 = Sheets("koru02") 'sayfaları set eder (ne demekse)
Set s3 = Sheets("koru03"): Set s4 = Sheets("koru04") 'sayfaları set eder (ne demekse)
Set s5 = Sheets("koru05") 'sayfaları set eder (ne demekse)
Set Fs = CreateObject("Scripting.FileSystemObject") 'bu ne demek?
'>>>>>D E Ğ İ Ş K E N L E R
Akt_Kit_Ad = ThisWorkbook.Name ' Aktif çalışma kitabının adı
Akt_Dzn_Ad = ThisWorkbook.Path ' Aktif çalışma kitabının dizini
kay_kit_ad = WorksheetFunction.Text(s1.Range("a1"), "mmyyyy") & "_test" ' Kaydedilecek yeni çalışma kitabının adı
Kay_Dzn_Ad = WorksheetFunction.Text(s1.Range("a1"), "yyyy") ' Kaydedilecek yeni çalışma kitabının dizini
'Kay_Yol_Ad = ThisWorkbook.Path & "\Sil\" ' Bu Satır Makroların denenmesi için kullanılacaktır.... Daha sonra silmeyi unutma HÜSEYİN
Kay_Yol_Ad = ThisWorkbook.Path & "\" ' Dizin yoksa oluşturulacağı yol (path)
HedefDizin = Kay_Yol_Ad & Kay_Dzn_Ad
'yck_adi = kay_kit_ad & ".xls"
HdfDznDsy = HedefDizin & "\" & kay_kit_ad & ".xls" ' Tam Yol İleri, yelkenler Fora
HdfDznDsy_kont = Fs.FileExists(HdfDznDsy)
'Taslak Sayfalar
cs_kr1 = "koru01": cs_kr2 = "koru02": cs_kr3 = "koru03"
cs_kr4 = "koru04": cs_kr5 = "koru05"
MsgBox "Asıl Kitapta Kalacak, Arşivlen Çalışma Kitabından Silenecek Çalışma Sayfaları" & _
vbCr & cs_kr1 & " / " & cs_kr2 & " / " & cs_kr3 & " / " & cs_kr4 & " / " & cs_kr5, vbInformation, "BİLGİ-01"
'>>>>>İ Ş L E M - 0 1 ---------------Kitabın Arşivleneceği Klasör Yoksa Oluştur, Varsa Mesaj Gönder
If Not Fs.FolderExists(HedefDizin) Then 'KONTROL
ChDir Kay_Yol_Ad 'Dizin oluşturulacağı klasöre git
MkDir Kay_Dzn_Ad: MsgBox Kay_Dzn_Ad & " Klasörü oluşturuldu.!" 'Yeni Dizini Oluştur, Mesaj ver
Else
MsgBox Kay_Dzn_Ad & " Klasörü var!" 'var mesajı var
End If
'<<<<<İ Ş L E M - 0 1 bitti.................
'>>>>>İ Ş L E M - 0 2 ---------------Aktif Kitabı (kay_kit_ad) değişkeninin değeri ile kopyala
'değiştirme ve iptal olanağı sağlar
If HdfDznDsy_kont = True Then ' Dosya var ise
Cevap = MsgBox(HdfDznDsy & ".xls" & vbCr & "Bu isimde bir dosya var, işlem yapmaya devam edecekmisiniz?" & vbCr & _
"Aynı İsimle Kaydetmek için EVET'e, Farklı Kaydetmek için HAYIR'a," & vbCr & "İptal için İPTAL'e basınız!", _
vbYesNoCancel, "UYARI")
If Cevap = vbYes Then 'aynı isim ile kaydeder
MsgBox HedefDizin & "\" & kay_kit_ad & ".xls ismi ile Kaydedilecektir."
ActiveWorkbook.SaveCopyAs HedefDizin & "\" & kay_kit_ad & ".xls"
ElseIf Cevap = vbNo Then 'inputboxa girilen değer ile kaydeder
kay_kit_ad = InputBox("Yeni Bir ad giriniz")
HdfDznDsy = HedefDizin & "\" & kay_kit_ad & ".xls"
MsgBox HdfDznDsy & " ismi ile Kaydedilecektir."
ActiveWorkbook.SaveCopyAs HdfDznDsy
Else 'iptal eder
MsgBox "İşlem kullanıcı tarafından iptal edildi."
Exit Sub
End If
Else 'dosya yok ise oluşturur
ActiveWorkbook.SaveCopyAs HdfDznDsy
End If
'ActiveWorkbook.SaveCopyAs HdfDznDsy
'NOT>>>>>>>> bu satırın üstündekini aktif edip diğerlerini İŞLEM 02 BAŞLIĞINA kadar silince doğrudan kopyalar
'<<<<<İ Ş L E M - 0 2 bitti.................
'>>>>>İ Ş L E M - 0 3 ---------------Arşivlenen çalışma kitabından makroları sil
Set wbActiveBook = Workbooks.Open(HdfDznDsy) '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
'<<<<<İ Ş L E M - 0 3 bitti.................
'Exit Sub
HdfDznDsy = HedefDizin & "\" & kay_kit_ad & ".xls"
MsgBox kay_kit_ad & ".xls" & " kapatılmmıştır"
ChDir HedefDizin
Workbooks.Open Filename:=HdfDznDsy '& kay_kit_ad & ".xls"
MsgBox kay_kit_ad & ".xls" & " Açılmıştır"
MsgBox ActiveWorkbook.Name, , "kontrol"
'>>>>>İ Ş L E M - 0 4 --------------- Korunan çalışma sayfalarına eşit olmayanları sil
'Arşivlenen dosyadan aktarım yapılan sayfaları siler
For i = Worksheets.Count To 1
'For i = 1 To Worksheets.Count
cs_ad = Worksheets(i).Name: MsgBox i & " " & cs_ad, , "22222222222"
If Worksheets(i).Name = cs_kr1 Or Worksheets(i).Name = cs_kr2 Or Worksheets(i).Name = cs_kr3 Or _
Worksheets(i).Name = cs_kr4 Or Worksheets(i).Name = cs_kr5 Then
Worksheets(i).Delete
'Sheets(i).Delete
MsgBox cs_ad & " Arşiv Kitaptan Silinecektir", , "A R Ş İ V"
Else
End If
Next i
'>>>>>İ Ş L E M - 0 5 ---------------Arşivlenen çalışma kitabını kaydet ve kapat
ActiveWorkbook.Save 'DEĞİŞKEN adlı dosyayı kaydet
ActiveWorkbook.Close 'DEĞİŞKEN adlı dosyayı kapat
'<<<<<İ Ş L E M - 0 5 bitti.................
'>>>>>S O N ---------------------Aktif Kitabı (kay_kit_ad) değişkeninin değeri ile kopyala
MsgBox "İşleminiz Tamamlanmıştır", , "www.excel.web.tr"
'<<<<<S O N ------bitti..........
End Sub