• DİKKAT

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

Farklı kaydet sorunları

G

gnorar

Katılım
11 Kasım 2004
Mesajlar
80
Excel kitabı sayfalarını yeni oluşturulan bir kitaba makrosuz olarak kopyalattırarak yeni bir adla kaydettirmek için aşağıdaki makroyu kullanıyorum.

Sub Kopyala()
Dim WS As Worksheet
Dim i As Integer
Dim sarrWS() As String
ReDim sarrWS(1 To ThisWorkbook.Worksheets.Count)
i = 0
For Each WS In ThisWorkbook.Worksheets
i = i + 1
sarrWS(i) = WS.Name
Next WS
ThisWorkbook.Worksheets(sarrWS()).Copy
Application.Dialogs(xlDialogSaveAs).Show
End Sub

Bu makroya 2 özellik eklemek istiyorum.

1)Makro asıl dosyada bulunan "stok" ve "sonuç" sayfalarını kopyalatmayacak, diğer sayfalar kopyalanacak. (Bu konuda birçok denemem oldu ancak hepsi hüsranla sonuçlandı.)

2)Ana dosya sayfaları şifreyle korunmuş durumda, kopya dosyasında ise sayfaların koruma şifresiyle korunmasını istemiyorum, yani sayfalar kopyalanırken sayfa koruma özellikleri kopyalanmacak.

Yukarıdaki makro bu özellikleri kapsayacak şekilde nasıl yeniden düzenlenebilir? Veya bu işlemleri yaptıracak başka bir mokro nasıl yazılır?
 
sayfaları kopyalayarak ana dosyanın klasörüne, dosya ismi = sayfa ismi olacak şekilde kopyalar, dosyayı kapatır.

kaydet + kapa için farklı kod kullanacaksanız şu satırları silin:
ActiveWorkbook.SaveAs Filename:=fpath & ws.Name
ActiveWorkbook.Close


sayfa koruma şifresi 123 var sayılmıştır. buraya doğrusunu yazın veya şifre yoksa ilgili bölümü silin.

Kod: 
Sub Kopyala()

Dim wb As Workbook, ws As Worksheet
Dim fpath As String

Set wb = ThisWorkbook
fpath = wb.Path
If Right(fpath, 1) <> "\" Then fpath = fpath & "\"

For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> "stok" And ws.Name <> "sonuç" Then
        ws.Copy
        ws.Unprotect Password:="123"
        ActiveWorkbook.SaveAs Filename:=fpath & ws.Name
        ActiveWorkbook.Close
    End If
Next

End Sub
 
Yanıtınız için teşekkürler. Ancak ben kopyalama işlemlerini "farklı kaydet dialog penceresi" vasıtasıyla yaptırıyorum ve bu özelliğin devam etmesini istiyorum. Yazdığınız kodda bu özellik yok. Nasıl düzeltilebilir?
 
Kod: 
Sub Kopyala()

Dim ws As Worksheet
Dim fName As String

For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> "stok" And ws.Name <> "sonuç" Then
        ws.Copy
        ws.Unprotect Password:="123"
        fName = Application.GetSaveAsFilename
        If fName = "False" Then Exit Sub
        ActiveWorkbook.SaveAs fName
    End If
Next

End Sub
 
mancubus' Alıntı:
Kod: 
Sub Kopyala()

Dim ws As Worksheet
Dim fName As String

For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> "stok" And ws.Name <> "sonuç" Then
        ws.Copy
        ws.Unprotect Password:="123"
        fName = Application.GetSaveAsFilename
        If fName = "False" Then Exit Sub
        ActiveWorkbook.SaveAs fName
    End If
Next

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


Yazdığınız kod stok ve sonuç sayfaları dışındaki tüm sayfaları kopyalamıyor ve farklı kaydet diyalog penceresi doğru çalışmıyor. Kodu tekrar inceler misiniz?
 
filtre eklememişiz. ofis 2003 versiyonu kullandığınızı farzediyorum.

sayfa konusunda problem yok. belirtilen isimler dışındaki tüm sayfaları kopyalıyor ve kaydediyor. 12 sayfa üzerinden test ettim, (stok ve sonuç dışında kalan) 10 sayfa için çalıştı.

Kod: 
Sub Kopyala()

Dim ws As Worksheet
Dim fName As String

For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> "stok" And ws.Name <> "sonuç" Then
        ws.Copy
        ws.Unprotect Password:="123"
        fName = Application.GetSaveAsFilename(FileFilter:="Excel Files (*.xls), *.xls")
        If fName = "False" Then Exit Sub
        ActiveWorkbook.SaveAs Filename:=fName, FileFormat:=xlExcel8
    End If
Next

End Sub
 
Yazdığınız makro sayfaları tek tek ayrı kitap halinde kaydettiriyor. Amacım sayfaları tek kitap altında bir seferde kaydettirmek. Bu arada Ofis 2010 kullanıyorum.
 
ben öyle yapmak istediğinizi düşünmüştüm.

o takdirde:

Kod: 
Sub Kopyala()

Dim WS As Worksheet
Dim fName As String

Application.DisplayAlerts = False
Application.ScreenUpdating = False

For Each WS In ThisWorkbook.Worksheets
    If WS.Name <> "stok" And WS.Name <> "sonuç" Then
        WS.Select False
    End If
Next
        
ActiveWindow.SelectedSheets.Copy

For Each WS In ActiveWorkbook.Worksheets
    WS.Unprotect Password:="123"
Next

fName = Application.GetSaveAsFilename(FileFilter:="Excel Files (*.xlsx), *.xlsx")
If fName = "False" Then Exit Sub
ActiveWorkbook.SaveAs Filename:=fName, FileFormat:=xlOpenXMLWorkbook
        
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub
 
Sn. mancubus, bugün sizi biraz yordum. Ancak eklediğim örnek dosyada olduğu gibi stok ve sonuç sayfaları da diğer sayfalar yanında kopyalanıyor. Diğer taraftan kopyalama işlemi bittikten sonra yedek dosyanın kapanmasını istiyorum. Ayrıca:

If fName = "False" Then Exit Sub
ActiveWorkbook.SaveAs Filename:=fName, FileFormat:=xlOpenXMLWorkbook

Kodları ne işe yarıyor, açıklarsanız sevinirim.
 

Ekli dosyalar

Alternatif kod

Kod: 
Sub calısmakitabiyap()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path 'Klasor.Items.Item.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

For r = Len(ThisWorkbook.Name) To 1 Step -1
If Mid(ThisWorkbook.Name, r, 1) = "." Then
'Dosya_adi = Mid(ThisWorkbook.Name, 1, r - 1)
Uzanti = Mid(ThisWorkbook.Name, r, Len(ThisWorkbook.Name))
Exit For
End If
Next
Dosya_adi = InputBox("UYARI!" & Chr(10) & _
Chr(10) & "  Yeni Dosya adını yazınız " & Chr(10) & Chr(10) & _
"", _
"DİKKAT !", "", , , "DEMO.HLP", 10)
If Dosya_adi = "" Then
MsgBox "dosya adını yazmadınız."
Exit Sub
End If

If Right(Kaynak, 1) = "\" Then
Kaynak = Kaynak
Else
Kaynak = Kaynak & "\"
End If
yer = MsgBox("Sayfada eğer makro varsa silmek istiyormusunuz.?", vbYesNo + vbInformation, " Makro silme penceresi")
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
git = ActiveSheet.Name
Dim ds, a
Set ds = CreateObject("Scripting.FileSystemObject")
Dim sayfa As Worksheet
Dim myArray() As Variant
Dim i As Integer
Dim j As Integer
j = 0
For i = 1 To Sheets.Count
r = 0
If Sheets(i).Name <> "stok" And Sheets(i).Name <> "sonuç" Then
r = 1
End If
If r = 1 Then
ReDim Preserve myArray(j)
myArray(j) = i
j = j + 1
End If
Next i
Sheets(myArray).Select
Sheets(myArray).Copy

For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).Files
If Mid(Dosya.Name, 1, Len(Dosya_adi)) = Dosya_adi Then
sat = sat + 1
a = ds.FileExists(Klasor & Dosya_adi & sat & Uzanti)
If a = True Then
Else
son = 1
Exit For
End If
End If
Next

If son = 0 Then
sat = ""
End If
deger = Dosya_adi & sat & Uzanti

For i = 1 To ActiveWorkbook.Sheets.Count
Sheets(Sheets(i).Name).Select
Worksheets(Sheets(i).Name).Protect Password:="123", Contents:=False, Scenarios:=False
ActiveSheet.DrawingObjects.Delete
Next

If yer = vbYes Then
ActiveSheet.DrawingObjects.Delete
For Each component In ActiveWorkbook.VBProject.VBComponents
If component.Type <> 100 Then
ActiveWorkbook.VBProject.VBComponents.Remove component
Else
Set modul = component.CodeModule
modul.DeleteLines 1, modul.CountOfLines
End If
Next
End If

ActiveWorkbook.Sheets(Sheets(1).Name).Select
ActiveWorkbook.SaveAs Kaynak & deger
ActiveWorkbook.Close SaveChanges:=False
Sheets(git).Select
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
MsgBox Kaynak & deger & Chr(10) & Chr(10) & _
"Kayıt yapıldı", vbInformation, deger
Else
Atla:
MsgBox "Lütfen Hedef Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
 

Ekli dosyalar

Sn. halit3 öncelikle yanıtınız için teşekkürler.
Makronuz çalıştırıldığında

For Each component In ActiveWorkbook.VBProject.VBComponents

satırına ilişkin "visual basic projesine programlı olarak erişim güvenli değil" hatası veriyor.

Eğer yanlış hatırlamıyorsam bu sorun excel ayarlarıyla ilgili. Hazırlamaya çalıştığım excel dosyası pek çok kişi tarafından çok değişken mekanlarda kullanılacak. Yani excel dosyasının her kullanıldığı bilgisayarda ayar yaptırmam mümkün değil. Bu nedenle yukarıda belirttiğim hatayı aşmak için kodda bir revizyon yapılabilir mi?
 
gnorar' Alıntı:
Sn. halit3 öncelikle yanıtınız için teşekkürler.
Makronuz çalıştırıldığında

For Each component In ActiveWorkbook.VBProject.VBComponents

satırına ilişkin "visual basic projesine programlı olarak erişim güvenli değil" hatası veriyor.

Eğer yanlış hatırlamıyorsam bu sorun excel ayarlarıyla ilgili. Hazırlamaya çalıştığım excel dosyası pek çok kişi tarafından çok değişken mekanlarda kullanılacak. Yani excel dosyasının her kullanıldığı bilgisayarda ayar yaptırmam mümkün değil. Bu nedenle yukarıda belirttiğim hatayı aşmak için kodda bir revizyon yapılabilir mi?
Genişletmek için tıkla ...

o zaman o bölümü iptal edin


Kod: 
Sub calısmakitabiyap()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path 'Klasor.Items.Item.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
For r = Len(ThisWorkbook.Name) To 1 Step -1
If Mid(ThisWorkbook.Name, r, 1) = "." Then
'Dosya_adi = Mid(ThisWorkbook.Name, 1, r - 1)
Uzanti = Mid(ThisWorkbook.Name, r, Len(ThisWorkbook.Name))
Exit For
End If
Next
Dosya_adi = InputBox("UYARI!" & Chr(10) & _
Chr(10) & "  Yeni Dosya adını yazınız " & Chr(10) & Chr(10) & _
"", _
"DİKKAT !", "", , , "DEMO.HLP", 10)
If Dosya_adi = "" Then
MsgBox "dosya adını yazmadınız."
Exit Sub
End If
If Right(Kaynak, 1) = "\" Then
Kaynak = Kaynak
Else
Kaynak = Kaynak & "\"
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
git = ActiveSheet.Name
Dim ds, a
Set ds = CreateObject("Scripting.FileSystemObject")
Dim sayfa As Worksheet
Dim myArray() As Variant
Dim i As Integer
Dim j As Integer
j = 0
For i = 1 To Sheets.Count
r = 0
If Sheets(i).Name <> "stok" And Sheets(i).Name <> "sonuç" Then
r = 1
End If
If r = 1 Then
ReDim Preserve myArray(j)
myArray(j) = i
j = j + 1
End If
Next i
Sheets(myArray).Select
Sheets(myArray).Copy
For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).Files
If Mid(Dosya.Name, 1, Len(Dosya_adi)) = Dosya_adi Then
sat = sat + 1
a = ds.FileExists(Klasor & Dosya_adi & sat & Uzanti)
If a = True Then
Else
son = 1
Exit For
End If
End If
Next
If son = 0 Then
sat = ""
End If
deger = Dosya_adi & sat

For i = 1 To ActiveWorkbook.Sheets.Count
Sheets(Sheets(i).Name).Select
Worksheets(Sheets(i).Name).Protect Password:="123", Contents:=False, Scenarios:=False
ActiveSheet.DrawingObjects.Delete
Next
ActiveWorkbook.Sheets(Sheets(1).Name).Select
If Uzanti = ".xls" Then
ActiveWorkbook.SaveAs Kaynak & deger & Uzanti, FileFormat:=-4143
ElseIf Uzanti = ".xlsx" Then
ActiveWorkbook.SaveAs Kaynak & deger & Uzanti, FileFormat:=51
ElseIf Uzanti = ".xlsb" Then
ActiveWorkbook.SaveAs Kaynak & deger & Uzanti, FileFormat:=50
ElseIf Uzanti = ".xlsm" Then
ActiveWorkbook.SaveAs Kaynak & deger & ".xlsx", FileFormat:=51
Uzanti = ".xlsx"
End If
ActiveWorkbook.Close SaveChanges:=False
Sheets(git).Select
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
MsgBox Kaynak & deger & Uzanti & Chr(10) & Chr(10) & _
"Kayıt yapıldı", vbInformation, deger
Else
Atla:
MsgBox "Lütfen Hedef Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
 
Sn halit3 bu seferde xlsm uzantılı asıl dosyamda kodu çalıştırdığımda:

ActiveWorkbook.SaveAs Kaynak & deger

satırında: "Bu uzantı seçili dosya türüyle kullanılamaz. Dosya adı kutusunda dosya uzantısını değiştirin veya dosya türünü değiştirerek farklı bir dosya türü seçin." hatasını verdi.

Yarın zaman ayırıpta ilgilenebilirseniz yada windowsun farklı kaydet diyalog penceresini kodunuza monte edebilirseniz sevinirim. Şimdiden teşekkürler.
 
gnorar' Alıntı:
Sn halit3 bu seferde xlsm uzantılı asıl dosyamda kodu çalıştırdığımda:

ActiveWorkbook.SaveAs Kaynak & deger

satırında: "Bu uzantı seçili dosya türüyle kullanılamaz. Dosya adı kutusunda dosya uzantısını değiştirin veya dosya türünü değiştirerek farklı bir dosya türü seçin." hatasını verdi.

Yarın zaman ayırıpta ilgilenebilirseniz yada windowsun farklı kaydet diyalog penceresini kodunuza monte edebilirseniz sevinirim. Şimdiden teşekkürler.
Genişletmek için tıkla ...

12 nolu mesajdaki kodu yeniden düzenledim.
 
sayın halit3 güzel ve örnek bir çalışma oldu. Bemim için ufak bir pürüz kaldı. Kopya olarak oluşturulan dosyanın xlsm yerine xlsx formatında kaydedilmesi benim için çok daha yararlı olacak. Düzeltebilirseniz sevinirim.
 
gnorar' Alıntı:
sayın halit3 güzel ve örnek bir çalışma oldu. Bemim için ufak bir pürüz kaldı. Kopya olarak oluşturulan dosyanın xlsm yerine xlsx formatında kaydedilmesi benim için çok daha yararlı olacak. Düzeltebilirseniz sevinirim.
Genişletmek için tıkla ...

12 nolu mesajdaki kodu düzenledim.
 
Sn. mancubus, makromuzu tamamlayamasakta harcadığınız çabalar için teşekkür ederim.

Sn. halit3, çözümünüz ve harcadığınız emekler için teşekkür ederim. Güzel, yeni nesil excele uyumlu bir kod hazırlamış oldunuz. Bana faydalı olduğu gibi bir arama motorlarıyla bu konuya ulaşacak pek çok arkadaşa da yardımcı olacak bir makro oldu sanırım. Tekrar teşekkürler.
 
gnorar' Alıntı:
Sn. mancubus, makromuzu tamamlayamasakta harcadığınız çabalar için teşekkür ederim.

Sn. halit3, çözümünüz ve harcadığınız emekler için teşekkür ederim. Güzel, yeni nesil excele uyumlu bir kod hazırlamış oldunuz. Bana faydalı olduğu gibi bir arama motorlarıyla bu konuya ulaşacak pek çok arkadaşa da yardımcı olacak bir makro oldu sanırım. Tekrar teşekkürler.
Genişletmek için tıkla ...

İyi çalışmalar
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst