Farklı kaydette sayfa adını hücreden almak

[by_IsTaNBuL]

AŞAGIDAKİ SİZLERİN YAPMIŞ OLDUGU KODU KULLANMAK ISTIYORUM FAKAT BIR DEĞİŞİKLİK YAPABİLİRMİYİZ..
SAYFA ADINI SAYFADAKİ BİR HÜCREDEN ALABİLİRMİ
ÖRNEK ; SAYFA1 - A1 HÜCRESİ BU SAYFA ADINA TARİH VE SAAT TEE EKLEYEBLİRMİYİZ.

YARDIMCI OLURSANIZ ÇOK SEVİNECEĞİM.

ŞİMDİDEN ÇOK TESEKKURLER





Sub sayfayicalismakitabiyap1()

yer = MsgBox("Sayfada eğer makro varsa silmek istiyormusunuz.?", vbYesNo + vbInformation, " Makro silme penceresi")

deger = InputBox("dosyanın adı adını değiştirebilirsiniz.", "UYARI!", ActiveSheet.Name)
deger1 = InputBox("Sayfanın adını değiştirebilirsiniz.", "UYARI!", "sayfa1")
'dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name
'-------------------------------

Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, x As Long, pos As Integer
msg = "Lütfen bir klasör seçiniz."
bInfo.pidlRoot = 0&
If IsMissing(msg) Then
bInfo.lpszTitle = "Lütfen bir klasör seçiniz."
Else
bInfo.lpszTitle = msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
Path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal Path)
If r Then
pos = InStr(Path, Chr$(0))
Klasor = Left(Path, pos - 1)

Else
MsgBox "işlemi iptal ettiniz."
Exit Sub
End If


Dim FileExtStr As String
Dim FileFormatNum As Long

With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For i = Len(ThisWorkbook.Name) To 1 Step -1
'For i = 1 To Len(ThisWorkbook.Name)
If Mid(ThisWorkbook.Name, i, 1) = "." Then
Dosya_adi = Mid(ThisWorkbook.Name, 1, i - 1)
Uzanti = Mid(ThisWorkbook.Name, i, Len(ThisWorkbook.Name))
Exit For
End If
Next

Dim Sourcewb As Workbook
Set Sourcewb = ActiveWorkbook
Dim sayfa As Worksheet
For Each sayfa In Worksheets

If sayfa.Name = Sayfa_Adı Then

Dim ds, a
Set ds = CreateObject("Scripting.FileSystemObject")
a = ds.FileExists(Klasor & "\" & deger & Uzanti)
If a = True Then
MsgBox "Bu isimde bir dosya var"
'Exit Sub
Else

sayfa.Copy
'ActiveSheet.Copy

Dim wb As Workbook
Set wb = ActiveWorkbook

With wb
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else

If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
'MsgBox "HATA VAR"
FileExtStr = Right(Sourcewb.Name, 5)
FileFormatNum = 52
'Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With

With wb

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


Sheets(ActiveSheet.Name).Name = deger1

.SaveAs Klasor & "\" & deger & FileExtStr, FileFormat:=FileFormatNum
.Close SaveChanges:=False
End With
'MsgBox "Kayıt yeri " & Klasor & "\" & deger & FileExtStr
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
End If
Next

End Sub