çalışma sayfasını kitap olarak (kopya) kaydetme.

[aslan1071]

Benim sorunum kitap1 deki çalışma sayfasını d sürücüsüne çalışma sayfasının b8 hücresindeki isimle (bu isim devamlı farklı olacaktır) kaydetmek istiyorum. forumdaki konulara baktım 2-3 tane buna yakın konu var ama benim problemimimi çözmüyor. yardımcı olabilecek varsa sevinirim.

 

[Civan Jack]

http://www.excel.web.tr/f133/klasor-ve-dosya-olu-turma-secenekleri-t68040.html

 

[aslan1071]

http://www.excel.web.tr/f133/klasor-ve-dosya-olu-turma-secenekleri-t68040.html

civan bey ilginize çok teşekkürler eğer zamet olmaz ise yukarıda ekte bulunan kitabın yedek düğmesine uyaryarak tekrar göndermeniz mümkün olurmu? vaktiniz yoksa dahi çok teşekkürler.

 

[Civan Jack]

Sub kaydet22()

Sayfa_Adı = ActiveSheet.Name
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
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

For i = Len(ThisWorkbook.Name) To 1 Step -1
If Mid(ThisWorkbook.Name, i, 1) = "." Then
yer = Mid(ThisWorkbook.Name, 1, i - 1)
Uzanti = Mid(ThisWorkbook.Name, i, Len(ThisWorkbook.Name))
Exit For
End If
Next

yer = Kaynak & ActiveSheet.Range("B8").Value

ThisWorkbook.Worksheets.Select
ThisWorkbook.Worksheets.Copy

Application.DisplayAlerts = False
If Uzanti = ".xlsx" Then
ActiveWorkbook.SaveAs yer & ".xlsm", FileFormat:=52
ElseIf Uzanti = ".xlsm" Then
ActiveWorkbook.SaveAs yer & ".xlsm", FileFormat:=52
ElseIf Uzanti = ".xls" Then
ActiveWorkbook.SaveAs yer & ".xls", FileFormat:=-4143  'Uzanti
'ActiveWorkbook.SaveAs Filename:=yer & Uzanti
End If
For i = ActiveWorkbook.Sheets.Count To 1 Step -1
Sheets(i).Select
ActiveSheet.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"

Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub