Dosya Üzerine Kopyalama Sorunu

[htsumer]

Aşağıdaki kodu kullanıyorum. Bu Kod ile sayfayı alıp

C:\MTSK BANKA klasörü yoksa açıp içinde METİN olarak sayfa adı ile kaydediyor. Kod bazen çalışıyor bazende çalışmıyor sorunlu gibi ama asıl istediğim şu;
Bu kodu kullandığım 3 dosya var. Herbiri ayrı isimlerde 3 ayrı dosyada kodu çalıştırdığımda sayfa adları aynı olduğundan üzerine kopyalıyor ve 1 v2 dosya aktarımlarını silmiş oluyor.
Yani C:\MTSK BANKA klasöründe tek dosya oluşuyor adı "Halk Bankası Gönderme Formu" bu adın 3 dosyada aynı olması nedeniyle üzerine yazıyor.

İstediğim şu Sayfa adı "Halk Bankası Gönderme Formu" yerine dosya adını kaydetsin ki diğer dosyaları bozmasın..
Kod:

Sub Bilgileri_banka_Olarak_Kaydet()
Dim FileExtStr As String
Dim ds, a, b
Set ds = CreateObject("Scripting.FileSystemObject")
a = ds.FolderExists("C:\" & "\" & "MTSK BANKA")
If a = False Then
MsgBox "MTSK BANKA ADLI klasör yok MTSK BANKA adıyla oluşturulacak "
ds.CreateFolder "C:\" & "\" & "MTSK BANKA"
MsgBox "C:\DE MTSK BANKA KLASÖRÜ OLUŞTURULDU"
End If
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ChDir "C:\MTSK BANKA\"
kayıt = CreateObject("wscript.Shell").SpecialFolders.Item(ThisWorkbook.Path & "C:\MTSK BANKA\") & _
 ActiveSheet.Name & FileExtStr: ActiveSheet.Copy
For Each s In ActiveSheet.Shapes
ActiveSheet.Shapes.Range(s.Name).Delete
Next
ActiveWorkbook.ActiveSheet.UsedRange.Value = ActiveWorkbook.ActiveSheet.UsedRange.Value
ActiveWorkbook.SaveAs Filename:=kayıt, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set ds = Nothing
kayıt = Empty
MsgBox "C'DE MTSK BANKA KLASÖRÜ İÇİNE SAYFA KAYDEDİLDİ"
End Sub

 

[PLİNT]

Merhaba
kodlarınızın içindeki şu mavi sayfa adını

[SIZE="2"]kayıt = CreateObject("wscript.Shell").SpecialFolders.Item(ThisWorkbook.Path & "C:\MTSK BANKA\") & _
 [COLOR="Blue"]ActiveSheet.Name[/COLOR] & FileExtStr: ActiveSheet.Copy[/SIZE]

aşağıdaki kırmızı bölümle değişip denermisiniz?

[SIZE="2"]kayıt = CreateObject("wscript.Shell").SpecialFolders.Item(ThisWorkbook.Path & "C:\MTSK BANKA\") & _
[COLOR="Red"] ds.GetBaseName(ThisWorkbook.Name)[/COLOR] & FileExtStr: ActiveSheet.Copy
[/SIZE]

 

[htsumer]

Sayın Plint çok teşekkür ederim tam istediğim gibi oldu eline sağlık..