• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Kod birleştirme

ASLAN7410

ASLAN7410

Katılım
15 Temmuz 2012
Mesajlar
2,802
Excel Vers. ve Dili
Ofis 2021 TR 64 Bit
Merhaba, hayırlı akşamlar.

Aşağıdaki kod excel dosyasını açtığımda otomatik olarak dosyanın yedeğini alıyor.
Dosyanın yedeğini aldığında 14.12.2017 20_07_47 bu şekilde dosyanın adını yazıyor.

Benim yapmak istediğim dosyanın adını bu şekilde yazmasını istiyorum.
14.12.2017 20_07_47 Örnek1 Örnek1 yazan yer dosyanın adı.

Dosyanın adını siyahla belirtmiş olduğum yere eklemeye çalışıyorum hep hata veriyor.

Kod: 
Private Sub Workbook_Open()
If Application.UserName <> "ADMİN" Then
'MsgBox ("Dosyayı yedeklemeyi sadece ADMİN yapabilir,"), vbInformation
Exit Sub
End If

Set ds = CreateObject("Scripting.FileSystemObject")
ThisWorkbook.Save
yer = Environ("USERPROFILE") & "\DESKTOP\YEDEK"
If ds.FolderExists(yer) = False Then
ds.CreateFolder yer
End If

DosyaAdi = ThisWorkbook.FullName
uzanti = "." & ds.GetExtensionName(DosyaAdi)
[B]yol = yer & "/" & Format(Now, " dd.mm.yyyy hh_nn_ss") & uzanti[/B]
ds.CopyFile DosyaAdi, yol

End Sub

Dosyanın adını alan kod'da aşağıda.

Kod: 
Sub DosyanınAdı()
DosyaAdi = ThisWorkbook.Name
DosyaUzanti = LCase(Mid(DosyaAdi, InStr(1, DosyaAdi, ".", 1) + 1))
SadeceAd = Mid(DosyaAdi, 1, (Len(DosyaAdi) - Len(DosyaUzanti) - 1))
'MsgBox SadeceAd, vbInformation
End Sub

Yardımcı olur musunuz?

.
 

Ekli dosyalar

Son düzenleme:
Merhaba,
Dosyanızı indirme imkanım olmadığı için deneyemedim ama ilgili bölümü şu şekilde değiştirip dener misiniz?
Kod: 
DosyaAdi = ThisWorkbook.FullName
[COLOR="Blue"]DosyaUzanti = LCase(Mid(DosyaAdi, InStr(1, DosyaAdi, ".", 1) + 1))
SadeceAd = Mid(DosyaAdi, 1, (Len(DosyaAdi) - Len(DosyaUzanti) - 1))[/COLOR]
uzanti = "." & ds.GetExtensionName(DosyaAdi)
yol = yer & "/" & Format(Now, " dd.mm.yyyy hh_nn_ss") [COLOR="Blue"]& " " & SadeceAd[/COLOR] & uzanti
ds.CopyFile DosyaAdi, yol
 
Sayın faye_efsane ilginiz için çok teşekkür ediyorum.

Sizin yazmış olduğunuz gibi yaptığımda aşağıdaki hata mesajını veriyor.

Run-time error '52':
Bad file name or number
 
Merhaba,
Çalışma dosyanızı link olarak paylaşabilir misiniz?
Dosya üzerinden deneme yapayım. :)
 
Acaba

Kod: 
yol = yer & "[COLOR="Red"]/[/COLOR]" & Format(Now, " dd.mm.yyyy hh_nn_ss") & uzanti

yerine

Kod: 
yol = yer & "[COLOR="red"]\[/COLOR]" & Format(Now, " dd.mm.yyyy hh_nn_ss") & uzanti

olur mu?
 
Sayın Yusuf Bey, ilginiz için çok teşekkür ediyorum.

Sizin dediğiniz gibi de yaptım olmadı. Aşağıdaki hatayı veriyor.

Run-time error '52':
Bad file name or number

Kod: 
Private Sub Workbook_Open()
If Application.UserName <> "ADMİN" Then
'MsgBox ("Dosyayı yedeklemeyi sadece ADMİN yapabilir,"), vbInformation
Exit Sub
End If

Set ds = CreateObject("Scripting.FileSystemObject")
ThisWorkbook.Save
yer = Environ("USERPROFILE") & "\DESKTOP\YEDEK"
If ds.FolderExists(yer) = False Then
ds.CreateFolder yer
End If

DosyaAdi = ThisWorkbook.FullName
DosyaUzanti = LCase(Mid(DosyaAdi, InStr(1, DosyaAdi, ".", 1) + 1))
SadeceAd = Mid(DosyaAdi, 1, (Len(DosyaAdi) - Len(DosyaUzanti) - 1))
uzanti = "." & ds.GetExtensionName(DosyaAdi)
yol = yer & "\" & Format(Now, " dd.mm.yyyy hh_nn_ss") & " " & SadeceAd & uzanti
ds.CopyFile DosyaAdi, yol

End Sub
 
Arkadaşlar yapmak istediğim dosyayı açtığımda dosya otomatik olarak aşağıdaki gibi kaydetmesini istiyorum.

14.12.2017 20_07_47 Örnek1 Örnek1 yazan yer dosyanın adı.
 
dd.mm.yyyy

yerine

dd mm yyyy

ya da

ddmmyyyy

olur mu?
 
Muhtemelen bilgisayar ayarlarınızın dosya adında tarih formatlı veri istememesi neden oluyor.
 
Merhaba,
İlgili bölümü şu şekilde değiştiriniz.
Kod: 
DosyaAdi = ThisWorkbook.FullName
dosyaadi2 = ThisWorkbook.Name
DosyaUzanti = LCase(Mid(dosyaadi2, InStr(1, dosyaadi2, ".", 1) + 1))
SadeceAd = Mid(dosyaadi2, 1, (Len(dosyaadi2) - Len(DosyaUzanti) - 1))
uzanti = "." & ds.GetExtensionName(DosyaAdi)
yol = yer & "\" & Format(Now, " dd.mm.yyyy hh_nn_ss") & " " & SadeceAd & uzanti
ds.CopyFile DosyaAdi, yol
 
Sayın Yusuf Bey, aşağıdaki kod tarih, saat, dakika, saniye şeklinde kayıt yapıyor zaten.

Benim yapmak istediğim ayrıca bu kaydın yanına dosyanın adını eklemek.

Kod: 
Private Sub Workbook_Open()
If Application.UserName <> "ADMİN" Then
'MsgBox ("Dosyayı yedeklemeyi sadece ADMİN yapabilir,"), vbInformation
Exit Sub
End If

Set ds = CreateObject("Scripting.FileSystemObject")
ThisWorkbook.Save
yer = Environ("USERPROFILE") & "\DESKTOP\YEDEK"
If ds.FolderExists(yer) = False Then
ds.CreateFolder yer
End If

DosyaAdi = ThisWorkbook.FullName
uzanti = "." & ds.GetExtensionName(DosyaAdi)
yol = yer & "/" & Format(Now, " dd.mm.yyyy hh_nn_ss") & uzanti
ds.CopyFile DosyaAdi, yol

End Sub
 
Teşekkürler, Sizede hayırlı geceler, hayırlı çalışmalar.
 
Attığınız excel'de denedim, ama yer kısmına kendi masaüstümü gösterdiğimde sorunsuz çalıştı. Kastettiğiniz bu sanırım. Bir deneyip bilgi verebilir misiniz?

Kod: 
'If Application.UserName <> "ADMİN" Then
MsgBox ("Dosyayı yedeklemeyi sadece ADMİN yapabilir,"), vbInformation
Exit Sub
End If
Dim ad As Variant

Set ds = CreateObject("Scripting.FileSystemObject")
ThisWorkbook.Save
yer = Environ("USERPROFILE") & "\DESKTOP\YEDEK"
If ds.FolderExists(yer) = False Then
ds.CreateFolder yer
End If

ad = "Örnek1"

DosyaAdi = ThisWorkbook.FullName
DosyaUzanti = LCase(Mid(DosyaAdi, InStr(1, DosyaAdi, ".", 1) + 1))
SadeceAd = Mid(DosyaAdi, 1, (Len(DosyaAdi) - Len(DosyaUzanti) - 1))
uzanti = "." & ds.GetExtensionName(DosyaAdi)
yol = yer & "\" & Format(Now, " dd.mm.yyyy hh_nn_ss") & " " & ad & uzanti
ds.CopyFile DosyaAdi, yol
 
Sayın Taner Bey, göndermiş olduğunuz kod gayet güzel çalışıyor, ellerinize sağlık.

Ancak dosyanın adı sürekli sabit değil.
 
ASLAN7410' Alıntı:
Sayın Taner Bey, göndermiş olduğunuz kod gayet güzel çalışıyor, ellerinize sağlık.

Ancak dosyanın adı sürekli sabit değil.
Genişletmek için tıkla ...

Bunu da düşündüm ama açılışta kaydettiği için değeri hücreye vermedim. Ama isterseniz siz orayı a = Range("A1").Value diyerek A1 hücresine bağlayabilrsiniz.
 
Sayın Taner Bey çok teşekkür ediyorum.

Hayırlı geceler, hayırlı çalışmalar diliyorum.
 
Yardımcı olabildiysem ne mutlu bana. İyi çalışmalar dilerim :)
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst