Makro İle Yeni bir dosya Kaydet

[ormann]

İyi günler ;
Ekli dosyada ComboBox1 İle Açma ve Yerleşme Cet. ve Koruma Faaliyetleri cetv. isimli iki sayfayı seçebiliyorum.Benim Yapmak istediğim ComboBox1 ile sayfayı seçip aktar butonu ile Masaüstünde "KORUMA" isimli bir klasör oluşturup bu klasörün içerisine ComboBox1 ile seçtiğim sayfayı kopyalayıp aynı isimle bir dosya oluşturacak.
Not: 1-Kopyalanan dosya sadece tablo ve değerlerden oluşacak ,formül olmayacak.
2-Masaüstü yolunu makro kendisi bulacak.Bu konu ile ilgili olarak yardımlarınızı bekliyorum.saygılar.



http://dosya.co/28ym3mrohs6r/Cetvel.xls.html

 

[halit3]

Dosyanızdaki sayfalar korumalı onun için eğer değerleri ile kopyalanacaksa sayfa korumasının kalkması gerekiyor.

Kırmızı bölüm şifre yazan yere siz sayfa koruması parolasını yazın.

Sub Çalışma_Kitabı_Yap()

'On Error Resume Next

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")

sifre = "[COLOR="Red"]1234[/COLOR]"
masa = CreateObject("wscript.Shell").SpecialFolders.Item("Desktop") & "\KORUMA"
If fL.FolderExists(masa) = False Then
MkDir masa
End If

dosya = ThisWorkbook.FullName
'dosya_adi = fL.GetBaseName(dosya)
uzanti = "." & fL.GetExtensionName(dosya)

Kaynak = masa & "\"
yer = Sheets(ActiveSheet.Name).ComboBox1.Text

Sheets(yer).Copy '.ActiveSheet.Copy
'Sheets(yer).Name = deger1

Sheets(yer).Protect Password:=sifre, Contents:=False, Scenarios:=False
Dim X As Range
For Each X In Sheets(yer).Range(Sheets(yer).Cells(2, 1), Sheets(yer).Cells(54, 18)) ' [C1:G100]
If X.Value <> "" Then
X.Value2 = X.Value
End If
Next X
Sheets(yer).Protect Password:=sifre, Contents:=True, Scenarios:=True

ActiveSheet.DrawingObjects.Delete
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Kaynak & yer & uzanti
ActiveWorkbook.Close False
Application.DisplayAlerts = True
MsgBox "işlem tamam !", vbInformation, "DİKKAT"

End Sub

 

[ormann]

Halit bey çok teşekkür ederim.Yalnız kayıt yapılan dosyayı açarken "Açmaya çalıştığınız xls dosyası ,dosya uzantısı tarafından belirtilenden farklı bir biçimde.Dosyayı açmadan önce dosyanın bozulmadığını ve güvenilen bir kaynaktan geldiğini doğrulayın.Dosyayı şimdi açmak ister misiniz " diye bir uyarı veriyor.Bu uyarıyı vermeyecek şekilde kayıt yapılabilir mi?

 

[halit3]

Senin dosyandaki sayfa ismi (Açma ve Yerleşme Cet.)bu bu sayfa ile dosya yapınca
(Açma ve Yerleşme Cet..xls) böyle oluyor iki tane nokta var belki bundan oluyordur.

Uyarı: Sayfa isimlerini aksanlı harfler ve semboller kullanmayınız makro kodlarında bunlar bazen sıkıntı yaratır.

 

[ormann]

Başka isimle de aynısı oluyor.Halit bey.
Ayrıca sizden bir şey öğrenmek istiyorum.Sayfanın sadece değer ve tablo işe birlikte kopyalanması için hangi makro yazılır.

 

[halit3]

Bende deneme yapıyorum söylediğiniz gibi olmuyor.

Bunu kendinizde yapabilirsiniz makro kaydet yöntemiyle
Kopyala özel yapıştır seçeneği ile yapabilirsiniz.

 

[ormann]

Makro yolunu öğrenmek istemiştim

 

[halit3]

Makro yolunu öğrenmek istemiştim

Binden fazla mesajın olmuş makro kaydet yolu ile kapyala yapıştır durumunu yapamıyormusunuz.

ben makro kaydet yöntemi ile sayfanın hepsini en üsten seçtim ve kopyala özel yapıştırı seçtim ve esc tuşuna bastım bu koda ulaştım

Sub Makro1()
'
' Makro1 Makro
' Makro a tarafından 01.05.2018 tarihinde kaydedildi.
'

'
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("A1").Select
End Sub

bunu da diğer koda uyguladım.

Sub Çalışma_Kitabı_Yap2()

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")

sifre = "1234"
masa = CreateObject("wscript.Shell").SpecialFolders.Item("Desktop") & "\KORUMA"
If fL.FolderExists(masa) = False Then
MkDir masa
End If

dosya = ThisWorkbook.FullName
uzanti = "." & fL.GetExtensionName(dosya)

Kaynak = masa & "\"
yer = Sheets(ActiveSheet.Name).ComboBox1.Text

Sheets(yer).Copy
Sheets(yer).Protect Password:=sifre, Contents:=False, Scenarios:=False

[COLOR="Red"]Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select[/COLOR]
ActiveSheet.DrawingObjects.Delete
Sheets(yer).Protect Password:=sifre, Contents:=True, Scenarios:=True

Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Kaynak & yer & uzanti
ActiveWorkbook.Close False
Application.DisplayAlerts = True
MsgBox "işlem tamam !", vbInformation, "DİKKAT"

End Sub