Dosya Kayıt Yeri Hk

[ormann]

İyi günler; ekli dosyada kayıt butonuna bastığımda dosya "c:\DİKİLİLER" klasörünün içerisine kayıt yapılıyor.Benim yapmak istediğim ana dosya hangi klasörün içerisindeyse kopyalama da bu klasörün içerisine olacak.Desteğinizi bekliyorum.Saygılar
http://dosya.co/i0liplilaarj/örnek1.rar.html

Sub KOPYALA()
Application.ScreenUpdating = False
Set s2 = Sheets("DİKİLİ GİRİŞİ")
Set s1 = Sheets("TOPLAMDAMGA")
Set flk = CreateObject("Scripting.FileSystemObject")
Kayıt_Yeri = klasor & "\" & Dosya_adi & "." & "xls"
dosya2 = "BÖLME-PARTİ NO=" & s2.Range("Q3").Value ' dosyanın kendisi"
klasor = "c:\DİKİLİLER"
Dosya_adi = InputBox("BÖLME/PARTİ ADINI DEĞİŞTİREBİLİRSİNİZ.", "UYARI!", dosya2)
If Dosya_adi = "" Then MsgBox "BÖLME/PARTİ ADINI YAZMADINIZ.": Exit Sub
Kayıt_Yeri = klasor & "\" & Dosya_adi & "." & "xls"
If CreateObject("Scripting.FileSystemObject").FileExists(Kayıt_Yeri) = True Then
MsgBox " Bu isimde bir dosya var": Exit Sub
Else
ActiveWorkbook.Save
If flk.FolderExists(klasor) = False Then
MkDir klasor
End If
flk.CopyFile ThisWorkbook.FullName, Kayıt_Yeri
MsgBox "DOSYANIZ AŞAĞIDAKİ İSİMLE KAYIT YAPILMIŞTIR." & Chr(10) & Chr(10) & Kayıt_Yeri, vbInformation, "U Y A R I "
End If
Son_Dolu_Satir = s1.Range("D65536").End(xlUp).Row
Bos_Satir = Son_Dolu_Satir + 1
s1.Range("D" & Bos_Satir).Value = _
Application.WorksheetFunction.Max(s1.Range("D:D")) + 1
   
    s1.Range("E" & Bos_Satir).Value = s2.[Q3]
    s1.Range("F" & Bos_Satir).Value = s2.[Q4]
    s1.Range("G" & Bos_Satir).Value = s2.[M10]
    s1.Range("H" & Bos_Satir).Value = s2.[N10]
 
Application.EnableEvents = False
dosya = ActiveWorkbook.Name
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.ScreenUpdating = True

Sheets("TOPLAMDAMGA").Select
Application.Wait Now + TimeValue("00:00:01")
Sheets("DİKİLİ GİRİŞİ").Select

End Sub

 

[muygun]

Merhaba;

klasor = "c:\DİKİLİLER"

kısmını;

klasor = ThisWorkbook.Path

olarak değiştirin ve deneyin.
İyi çalışmalar.

 

[ormann]

Teşekkür ederim.Sayın Muygun