Dosya İsmini Hücreden Alma

[vurkan]

Arkadaşlar merhaba. Aşağıdaki kod için yardımınıza ihtiyacım var.
Bu kod ile ÖĞRENCİ PROGRAMI isimli dosyamın BİRLER isimli sayfasını masaüstüne PENDİK OSMANGAZİ İLKOKULU 1.SINIF.xlsx adıyla yeni bir dosya olarak kaydediyorum.
Ama programı kullanacak diğer okullar için bu isim uygun değil. Aynı isim kayıt yaptığım BİRLER sayfasının A1 hücresinde de yazıyor. Bu A1 hücresine her okul kendi adını yazacak. Bunun için kayıt yapılırken dosya adını BİRLER sayfasındaki A1 hücresinden nasıl aldırabilirim. Şimdiden teşekkürler.


Sub Kaydet()
Sheets("BİRLER").Select
Sheets("BİRLER").Copy
ChDir "C:\Users\LENOVO\Desktop"
ActiveWorkbook.SaveAs Filename:= _
"C:\Users\LENOVO\Desktop\PENDİK OSMANGAZİ İLKOKULU 1.SINIF.xlsx", FileFormat _
:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
Sheets("YAZICI").Select
Range("L4:M11").Select
ActiveCell.FormulaR1C1 = "1A"
End Sub

 

[vurkan]

Arkadaşlar aşağıdaki gibi sorunu çözdüm.

Sub Kaydet ()
Sheets("BİRLER").Select
Sheets("BİRLER").Copy
ChDir "C:\Users\LENOVO\Desktop"
ActiveWorkbook.SaveAs Filename:= _
"C:\Users\LENOVO\Desktop\" & Sheets("BİRLER").Range("A1").Text & ".xlsx", FileFormat _
:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
Sheets("YAZICI").Select
Range("L4:M11").Select
ActiveCell.FormulaR1C1 = "1A"
End Sub

 

[vurkan]

Arkadaşlar Merhaba bu kod benim bilgisayarımda çalışıyor ama başka bilgisayarda herhalde bilgisayar adından dolayı çalışmıyor.
ChDir "C:\Users\LENOVO\Desktop" benim bilgisayar LENOVO . bu kodda nasıl gir değişiklik yapmalıyım ki her bilgisayarda çalışsın. Saygılar

 

[EmrExcel16]

Merhaba aşağıdaki gibi deneyiniz.

Sub Kaydet()
    Sheets("BİRLER").Select
    Sheets("BİRLER").Copy
    Set WshShell = CreateObject("WScript.Shell")
    Desktop = WshShell.SpecialFolders("Desktop") + "\"
    ActiveWorkbook.SaveAs Filename:=Desktop & Sheets("BİRLER").Range("A1").Text & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
    Sheets("YAZICI").Select
    Range("L4:M11").Select
    ActiveCell.FormulaR1C1 = "1A"
End Sub

 

[vurkan]

Sayın EmrExcel16 ilgine teşekkür ediyorum. Kod gayet güzel çalıştı. Bilgi edinmek açısından Masaüstüne değilde dosyanın olduğu aynı klasöre kaydetmek isteseydik nasıl bir değişiklik gerekliydi. Saygılar

 

[EmrExcel16]

Rica ederim

Set WshShell = CreateObject("WScript.Shell")
Desktop = WshShell.SpecialFolders("Desktop") + "\"

Yukarıdaki satırları aşağıdaki şekilde değiştirmeniz gerekli.

Dosya = ThisWorkbook.path + "\"

 

[vurkan]

Çok teşekkür ediyorum. Sağolun. Saygılar

 

[EmrExcel16]

Rica ederim , sizde sağolun iyi çalışmalar.

 

[baydeniro]

Merhaba aşağıdaki gibi deneyiniz.

Sub Kaydet()
    Sheets("BİRLER").Select
    Sheets("BİRLER").Copy
    Set WshShell = CreateObject("WScript.Shell")
    Desktop = WshShell.SpecialFolders("Desktop") + "\"
    ActiveWorkbook.SaveAs Filename:=Desktop & Sheets("BİRLER").Range("A1").Text & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
    Sheets("YAZICI").Select
    Range("L4:M11").Select
    ActiveCell.FormulaR1C1 = "1A"
End Sub

Teşekkürler EmrExcel16, sağlıcakla kalın

 

[EmrExcel16]

Teşekkürler EmrExcel16, sağlıcakla kalın

Rica ederim , sizde sağlıcakla kalın iyi çalışmalar.