• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Makroları silerek farklı kaydetmek

  • Konbuyu başlatan Konbuyu başlatan YUSUF44
  • Başlangıç tarihi Başlangıç tarihi
YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,065
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Dosyamda aşağıdaki kodla dosyayı farklı kaydettiriyorum:

Kod: 
Sub frk_kaydet()
yol = ThisWorkbook.Path & "\" & "Kula " & [c1].Text & ".xls"
If CreateObject("Scripting.FileSystemObject").FileExists(yol) = True Then
MsgBox "Bu isimde bir dosya zaten mevcut. Kayıt yapılmayacak.", vbCritical, "UYARI"
Exit Sub
End If
ThisWorkbook.SaveAs yol
End Sub

Bu koda nasıl bir ilave yapmalıyız ki hem dosyayı belirtilen şekilde farklı kaydetsin hem de dosyadaki tüm makrolar ve düğmeleri silsin? VAr mıdır böyle bir uygulama?
 

Ekli dosyalar

Alternatif kod

Kod: 
Sub farklıkaytet()
yol = ThisWorkbook.Path & "\" & "Kula " & [c1].Text & ".xls"
If CreateObject("Scripting.FileSystemObject").FileExists(yol) = True Then
MsgBox "Bu isimde bir dosya zaten mevcut. Kayıt yapılmayacak.", vbCritical, "UYARI"
Exit Sub
End If
Sayfa_Adı = ActiveSheet.Name
ThisWorkbook.Worksheets.Select
ThisWorkbook.Worksheets.Copy
ActiveWorkbook.SaveAs Filename:=yol
 
[COLOR=red]For i = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(i).DrawingObjects.Delete
Next i[/COLOR]
 
For Each ModX In ActiveWorkbook.VBProject.VBComponents
Set VBComp = ActiveWorkbook.VBProject.VBComponents(ModX.Name)
ActiveWorkbook.VBProject.VBComponents.Remove VBComp
Set VBCodeMod = ActiveWorkbook.VBProject.VBComponents(ModX.Name).CodeModule
VBCodeMod.DeleteLines 1, VBCodeMod.CountOfLines
Next
ActiveWorkbook.Save
ActiveWindow.Close
Sheets(Sayfa_Adı).Select
MsgBox "işlem tamam"
End Sub
 
Teşekkürler arkadaşlar.

Her iki kod da farklı kaydetmede sorun çıkarmıyor ancak makro çalıştırılınca her ikisinde de kod penceresi açılıyor ve Run time error 1004 vb projesine programlı olarak erişim mümkün değil şeklinde uyarı veriyor.

Sayın Ömer Bey'in çözümünde modüller ve düğmeler aynen duruyor. Sayın Halit Bey'in çözümünde ise modüller siliniyor ama düğmeler duruyor.

Aslında çok elzem değil ama olsa güzel olurdu. Tekrar teşekkürler.
 
YUSUF44' Alıntı:
Teşekkürler arkadaşlar.

Her iki kod da farklı kaydetmede sorun çıkarmıyor ancak makro çalıştırılınca her ikisinde de kod penceresi açılıyor ve Run time error 1004 vb projesine programlı olarak erişim mümkün değil şeklinde uyarı veriyor.

Sayın Ömer Bey'in çözümünde modüller ve düğmeler aynen duruyor. Sayın Halit Bey'in çözümünde ise modüller siliniyor ama düğmeler duruyor.

Aslında çok elzem değil ama olsa güzel olurdu. Tekrar teşekkürler.
Genişletmek için tıkla ...

Yusuf bey,

Makro/Güvenlik ekranında "Visual Basic Project erişimine güven" seçeneğini işaretlediniz mi?

Düğmeleri silmek için kodların sonuna aşağıdaki kodu eklersiniz.

For i = 1 To Worksheets.Count
Sheets(i).DrawingObjects.Delete
Next i

Yada,

For i = 1 To Worksheets.Count
For Each Nesne In Sheets(i).Shapes
Nesne.Delete
Next Nesne
Next i


.
 
Ömer' Alıntı:
Yusuf bey,

Makro/Güvenlik ekranında "Visual Basic Project erişimine güven" seçeneğini işaretlediniz mi?

Düğmeleri silmek için kodların sonuna aşağıdaki kodu eklersiniz.

For i = 1 To Worksheets.Count
Sheets(i).DrawingObjects.Delete
Next i

Yada,

For i = 1 To Worksheets.Count
For Each Nesne In Sheets(i).Shapes
Nesne.Delete
Next Nesne
Next i


.
Genişletmek için tıkla ...

Çok teşekkürler. Şimdi oldu:)
 
YUSUF44' Alıntı:
Teşekkürler arkadaşlar.

Her iki kod da farklı kaydetmede sorun çıkarmıyor ancak makro çalıştırılınca her ikisinde de kod penceresi açılıyor ve Run time error 1004 vb projesine programlı olarak erişim mümkün değil şeklinde uyarı veriyor.

Sayın Ömer Bey'in çözümünde modüller ve düğmeler aynen duruyor. Sayın Halit Bey'in çözümünde ise modüller siliniyor ama düğmeler duruyor.

Aslında çok elzem değil ama olsa güzel olurdu. Tekrar teşekkürler.
Genişletmek için tıkla ...

kodun bu bölümü düğmeleri siliyor olması lazım.

Kod: 
For i = ActiveWorkbook.Sheets.Count To 1 Step -1
Sheets(i).Select
ActiveSheet.DrawingObjects.Delete
Next i

eğer silmiyorsa aşağıdaki ile değiştirin

Kod: 
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(i).DrawingObjects.Delete
Next i
 
halit3' Alıntı:
kodun bu bölümü düğmeleri siliyor olması lazım.

Kod: 
For i = ActiveWorkbook.Sheets.Count To 1 Step -1
Sheets(i).Select
ActiveSheet.DrawingObjects.Delete
Next i

eğer silmiyorsa aşağıdaki ile değiştirin

Kod: 
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(i).DrawingObjects.Delete
Next i
Genişletmek için tıkla ...

Teşekkürler Halit Bey. Düğmeler de siliniyor ama bu sefer de farklı bir hata veriyor:

Kod: 
Runtime error '-2147024809 (80070057)':

Belirlenen kolaksiyona olan dizin sınırlar dışında.
 
halit3' Alıntı:
aşağıdaki linkleri bir inceleyin.

http://www.google.com.tr/#q=Runtime...f.,cf.osb&fp=77f82e7dd2afd68b&biw=960&bih=431
Genişletmek için tıkla ...

Halit Bey, soruna çözüm bulamadım maalesef. Korhan Bey'in çözümü de dosyayı farklı kaydedip düğmeleri siliyor ama makroları silmiyormuş, şimdi fark ettim.

Bu dosya bize makrosuz gönderildi, çok amatörce hazırlanmış bir dosyaydı ve kullanıcı dostu değildi. Ben işi kolaylaştırmak için bir kaç makro ekledim. Dosyayı sık aralıklarla makrosuz olarak tekrar düzenleyen kişiye göndermemiz gerekiyor. Bu nedenle makrosuz olması önemli.

Sizin son çözümünüzde düğmeler ve makrolar siliniyor ama o bahsettiğim hatayı veriyor. O hatayı yok etmenin yöntemi yok mudur?
 
YUSUF44' Alıntı:
Halit Bey, soruna çözüm bulamadım maalesef. Korhan Bey'in çözümü de dosyayı farklı kaydedip düğmeleri siliyor ama makroları silmiyormuş, şimdi fark ettim.

Bu dosya bize makrosuz gönderildi, çok amatörce hazırlanmış bir dosyaydı ve kullanıcı dostu değildi. Ben işi kolaylaştırmak için bir kaç makro ekledim. Dosyayı sık aralıklarla makrosuz olarak tekrar düzenleyen kişiye göndermemiz gerekiyor. Bu nedenle makrosuz olması önemli.

Sizin son çözümünüzde düğmeler ve makrolar siliniyor ama o bahsettiğim hatayı veriyor. O hatayı yok etmenin yöntemi yok mudur?
Genişletmek için tıkla ...

Bu kodu denermisiniz.

Kod: 
Sub farklıkaytet()
yol = ThisWorkbook.Path & "\" & "Kula " & [c1].Text & ".xls"
If CreateObject("Scripting.FileSystemObject").FileExists(yol) = True Then
MsgBox "Bu isimde bir dosya zaten mevcut. Kayıt yapılmayacak.", vbCritical, "UYARI"
Exit Sub
End If
Sayfa_Adı = ActiveSheet.Name
ThisWorkbook.Worksheets.Select
ThisWorkbook.Worksheets.Copy
ActiveWorkbook.SaveAs Filename:=yol
 
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(i).DrawingObjects.Delete
Next i
 
ActiveWorkbook.Save
ActiveWindow.Close
Sheets(Sayfa_Adı).Select
MsgBox "işlem tamam"
End Sub
 
Ofis 2003 de bu kodda çalışıyor sadece hata kodu ekledim.

Kod: 
Sub farklıkaytet()
yol = ThisWorkbook.Path & "\" & "Kula " & [c1].Text & ".xls"
If CreateObject("Scripting.FileSystemObject").FileExists(yol) = True Then
MsgBox "Bu isimde bir dosya zaten mevcut. Kayıt yapılmayacak.", vbCritical, "UYARI"
Exit Sub
End If
Sayfa_Adı = ActiveSheet.Name
ThisWorkbook.Worksheets.Select
ThisWorkbook.Worksheets.Copy
ActiveWorkbook.SaveAs Filename:=yol
 
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(i).DrawingObjects.Delete
Next i
[COLOR=red][B] On Error Resume Next[/B][/COLOR]
 
For Each ModX In ActiveWorkbook.VBProject.VBComponents
Set VBComp = ActiveWorkbook.VBProject.VBComponents(ModX.Name)
ActiveWorkbook.VBProject.VBComponents.Remove VBComp
Set VBCodeMod = ActiveWorkbook.VBProject.VBComponents(ModX.Name).CodeModule
VBCodeMod.DeleteLines 1, VBCodeMod.CountOfLines
Next
ActiveWorkbook.Save
ActiveWindow.Close
Sheets(Sayfa_Adı).Select
MsgBox "işlem tamam"
End Sub
 
halit3' Alıntı:
Bu kodu denermisiniz.

Kod: 
Sub farklıkaytet()
yol = ThisWorkbook.Path & "\" & "Kula " & [c1].Text & ".xls"
If CreateObject("Scripting.FileSystemObject").FileExists(yol) = True Then
MsgBox "Bu isimde bir dosya zaten mevcut. Kayıt yapılmayacak.", vbCritical, "UYARI"
Exit Sub
End If
Sayfa_Adı = ActiveSheet.Name
ThisWorkbook.Worksheets.Select
ThisWorkbook.Worksheets.Copy
ActiveWorkbook.SaveAs Filename:=yol
 
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(i).DrawingObjects.Delete
Next i
 
ActiveWorkbook.Save
ActiveWindow.Close
Sheets(Sayfa_Adı).Select
MsgBox "işlem tamam"
End Sub
Genişletmek için tıkla ...

Allah razı olsun Halit Bey. Tam oldu şimdi. Sadece farklı kaydederken xls uzantısıyla kaydettiği için yeni dosyayı açmak istediğimde "dosya uzantısı farklıdır" diye uyarı veriyordu ben de kodun uzantı kısmını xlsx yaptım ve o hatadan da kurtuldum.

Buna bağlı olarak şunu sormak istiyorum, eğer dosyayı göndereceğimiz kişide 2007 ve üstü yoksa, problem çıkmaması için, belirttiğim uzantı hatası vermeden dosyayı 97-2003 dosyası olarak kaydetme imkanı var mıdır? (Normalde varsayılan olarak 97-2003 dosyası olarak kaydediyorum dosyaları)
 
YUSUF44' Alıntı:
Allah razı olsun Halit Bey. Tam oldu şimdi. Sadece farklı kaydederken xls uzantısıyla kaydettiği için yeni dosyayı açmak istediğimde "dosya uzantısı farklıdır" diye uyarı veriyordu ben de kodun uzantı kısmını xlsx yaptım ve o hatadan da kurtuldum.

Buna bağlı olarak şunu sormak istiyorum, eğer dosyayı göndereceğimiz kişide 2007 ve üstü yoksa, problem çıkmaması için, belirttiğim uzantı hatası vermeden dosyayı 97-2003 dosyası olarak kaydetme imkanı var mıdır? (Normalde varsayılan olarak 97-2003 dosyası olarak kaydediyorum dosyaları)
Genişletmek için tıkla ...

kod


Kod: 
Sub farklıkaytet()
Sayfa_Adı = ActiveSheet.Name
For i = Len(ThisWorkbook.Name) To 1 Step -1
If Mid(ThisWorkbook.Name, i, 1) = "." Then
Uzanti = Mid(ThisWorkbook.Name, i, Len(ThisWorkbook.Name))
Exit For
End If
Next
yol = ThisWorkbook.Path & "\" & "Kula " & [c1].Text
If CreateObject("Scripting.FileSystemObject").FileExists(yol & Uzanti) = True Then
MsgBox "Bu isimde bir dosya zaten mevcut. Kayıt yapılmayacak.", vbCritical, "UYARI"
Exit Sub
End If
ThisWorkbook.Worksheets.Select
ThisWorkbook.Worksheets.Copy
Application.DisplayAlerts = False
If Uzanti = ".xlsx" Then
ActiveWorkbook.SaveAs yol & ".xlsm", FileFormat:=52
ElseIf Uzanti = ".xlsm" Then
ActiveWorkbook.SaveAs yol & ".xlsm", FileFormat:=52
ElseIf Uzanti = ".xls" Then
ActiveWorkbook.SaveAs yol & ".xls", FileFormat:=-4143  'Uzanti
End If
For i = ActiveWorkbook.Sheets.Count To 1 Step -1
ActiveWorkbook.Sheets(i).DrawingObjects.Delete
Next i
'On Error Resume Next
For Each ModX In ActiveWorkbook.VBProject.VBComponents
'Set VBComp = ActiveWorkbook.VBProject.VBComponents(ModX.Name)
'ActiveWorkbook.VBProject.VBComponents.Remove VBComp
Set VBCodeMod = ActiveWorkbook.VBProject.VBComponents(ModX.Name).CodeModule
VBCodeMod.DeleteLines 1, VBCodeMod.CountOfLines
Next
ActiveWorkbook.Save
ActiveWindow.Close
Sheets(Sayfa_Adı).Select
MsgBox "işlem tamam"

End Sub
 
halit3' Alıntı:
kod

Kod: 
Sub farklıkaytet()
[COLOR=red][B]For i = Len(ThisWorkbook.Name) To 1 Step -1[/B][/COLOR]
[COLOR=red][B]If Mid(ThisWorkbook.Name, i, 1) = "." Then[/B][/COLOR]
[B][COLOR=red]Uzanti = Mid(ThisWorkbook.Name, i, Len(ThisWorkbook.Name))[/COLOR][/B]
[B][COLOR=red]Exit For[/COLOR][/B]
[B][COLOR=red]End If[/COLOR][/B]
[B][COLOR=red]Next[/COLOR][/B]
yol = ThisWorkbook.Path & "\" & "Kula " & [c1].Text & [COLOR=red][B]Uzanti[/B][/COLOR]
If CreateObject("Scripting.FileSystemObject").FileExists(yol) = True Then
MsgBox "Bu isimde bir dosya zaten mevcut. Kayıt yapılmayacak.", vbCritical, "UYARI"
Exit Sub
End If
 
Sayfa_Adı = ActiveSheet.Name
ThisWorkbook.Worksheets.Select
ThisWorkbook.Worksheets.Copy
ActiveWorkbook.SaveAs Filename:=yol
 
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(i).DrawingObjects.Delete
Next i
 On Error Resume Next
 
For Each ModX In ActiveWorkbook.VBProject.VBComponents
Set VBComp = ActiveWorkbook.VBProject.VBComponents(ModX.Name)
ActiveWorkbook.VBProject.VBComponents.Remove VBComp
Set VBCodeMod = ActiveWorkbook.VBProject.VBComponents(ModX.Name).CodeModule
VBCodeMod.DeleteLines 1, VBCodeMod.CountOfLines
Next
ActiveWorkbook.Save
ActiveWindow.Close
Sheets(Sayfa_Adı).Select
MsgBox "işlem tamam"
End Sub

not:dosya hangi uzantıdaysa kayıt o uzantıya göre yapılacaktır
Genişletmek için tıkla ...

Halit Bey, bu da aynı hatayı verdi. Ayrıca nedendir bilmiyorum, o anda açık olan başka dosyamdaki düğmeleri de sildi ve yazıcıyla olan bağlantımı da kesti.

sonuç olarak bir önceki haline döndürdüm. Fazla kurcalamadan çalışan en ideal halini kullanayım bari:) Ne demişler: çalışıyorsa bozma:)
 
YUSUF44' Alıntı:
Halit Bey, bu da aynı hatayı verdi. Ayrıca nedendir bilmiyorum, o anda açık olan başka dosyamdaki düğmeleri de sildi ve yazıcıyla olan bağlantımı da kesti.

sonuç olarak bir önceki haline döndürdüm. Fazla kurcalamadan çalışan en ideal halini kullanayım bari:) Ne demişler: çalışıyorsa bozma:)
Genişletmek için tıkla ...

14 nolu mesajdaki dosyayı güncelledim.
 
halit3' Alıntı:
14 nolu mesajdaki dosyayı güncelledim.
Genişletmek için tıkla ...

Maalesef yine dosya uzantı hatası verdi. Belki de benim varsayılanı 97-2003 seçmemdendir. Daha fazla vaktinizi almayayım. Şu anda ideale en yakın halini kullanıyorum zaten. ilginize çok teşekkürler.
 
YUSUF44' Alıntı:
Maalesef yine dosya uzantı hatası verdi. Belki de benim varsayılanı 97-2003 seçmemdendir. Daha fazla vaktinizi almayayım. Şu anda ideale en yakın halini kullanıyorum zaten. ilginize çok teşekkürler.
Genişletmek için tıkla ...

Bende ikiside çalışıyor
 

Ekli dosyalar

halit3' Alıntı:
Bende ikiside çalışıyor
Genişletmek için tıkla ...

xls uzantılıyı denediğimde dosyayı oluşturuyor, problem yok. Ancak oluşturulan dosyayı açmak istediğimde ekteki hatayı veriyor:

xlsm uzantılıda hata oluşmuyor.
 

Ekli dosyalar

  • hata.jpg
    hata.jpg
    69.2 KB · Görüntüleme: 3
YUSUF44' Alıntı:
xls uzantılıyı denediğimde dosyayı oluşturuyor, problem yok. Ancak oluşturulan dosyayı açmak istediğimde ekteki hatayı veriyor:

xlsm uzantılıda hata oluşmuyor.
Genişletmek için tıkla ...


Siz 2003 dosyayı 2007 açtığınızdan oluyordu sorun 14 nolu mesajdaki kodu yeniden düzenledim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst