• DİKKAT

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

Yıla göre hücredeki isimle kayıt

S

SİBEL70

Katılım
22 Aralık 2005
Mesajlar
86
Merhabalar,

Ekteki dosyada; farklı kaydetle, Sayfa1 üzerindeki düğmeye tıklandığında a1 hücresindeki isimle C klasörünün altına, çalışma dosyasını kopyalıyor. Yapmak istediğim çalışma dosyasını, C Klasörünün altınaki KAYIT isimli klasöre, n1 hücresindeki tarihin yıl kısmına bakarak yıla ait klasör yoksa ilgili yılın adıyla klasör oluşturmak ve kaydedeceğim dosyayı b1 hücresindeki yıla göre ilgili yılın klasörüne kaydetmek. Yardımcı olabilirseniz sevinirim

Saygılar,
 

Ekli dosyalar

Son düzenleme:
Sayın dentex,

İlginiz için teşekkürler, Kayıt Klasöründe 2010 klasörünü açıyor ancak excel çalışma dosyasını, açtığı 2010 klasörüne kopyalamıyor. Excel dosyasının adının önüne 2010 getirerek doğrudan kayıt klasörünün içine atıyor. Kaydı C:\KAYIT\2010\.... xls şeklinde yapabilmek mümkün olur ise sevinirim.
Saygılar,
 
İyi akşamlar,
Kod: 
ActiveWorkbook.SaveAs Filename:="C:\KAYIT\" & kls2 & Worksheets("Sayfa1").Range("a1").Value & ".xls"
satırını,
Kod: 
ActiveWorkbook.SaveAs Filename:="C:\KAYIT\" & kls2 & "\" & Worksheets("Sayfa1").Range("a1").Value & ".xls"
ile değiştirerek deneyiniz, saygılar.
 
SİBEL70' Alıntı:
Merhabalar,

Ekteki dosyada; farklı kaydetle, Sayfa1 üzerindeki düğmeye tıklandığında a1 hücresindeki isimle C klasörünün altına, çalışma dosyasını kopyalıyor. Yapmak istediğim çalışma dosyasını, C Klasörünün altınaki KAYIT isimli klasöre, n1 hücresindeki tarihin yıl kısmına bakarak yıla ait klasör yoksa ilgili yılın adıyla klasör oluşturmak ve kaydedeceğim dosyayı b1 hücresindeki yıla göre ilgili yılın klasörüne kaydetmek. Yardımcı olabilirseniz sevinirim

Saygılar,
Genişletmek için tıkla ...

bunu denermisiniz.

Sub FARKLIKAYDET()
ActiveWorkbook.Save
ad = "C:\KAYIT"
On Error Resume Next
If Dir(ad) = "" Then MkDir ad
yer = Format(Cells(1, "n").Value, "yyyy")
On Error Resume Next
deg1 = ad & "\" & yer
If Dir(deg1) = "" Then MkDir (deg1)
deg2 = Cells(1, "b").Value & ".xls"
dosya_adı = Cells(1, "b").Value
sat = 0
For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(deg1).Files
If Trim(Mid(Dosya.Name, 1, Len(Cells(1, "b").Value))) = Trim(Cells(1, "b").Value) Then
sat = sat + 1
MsgBox sat
End If
Next
Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
Dim ds, a
Set ds = CreateObject("Scripting.FileSystemObject")
a = ds.FileExists(deg1 & "\" & deg2)
If a = True Then
'MsgBox "Bu isimde bir dosya var"
'On Error Resume Next
DosyaSistemi.CopyFile ThisWorkbook.FullName, (deg1 & "\" & dosya_adı & sat) & ".xls"
Else
'On Error Resume Next
'MsgBox "Bu isimde bir dosya yok"
DosyaSistemi.CopyFile ThisWorkbook.FullName, (deg1 & "\" & dosya_adı) & ".xls"
End If
End Sub
Genişletmek için tıkla ...

aynı isimle olan dosyaları sırası ile kayıt yapıyor.

örnek deneme isimli bir dosyayı
deneme
deneme1
deneme2

gibi
 
Sayın; dentex desteğiniz için teşekkürler.. Bu şekilde sorunsuz çalışıyor.
Sayın; Halit3 kodu dosyada çalıştırdığımda, en üst satırında "ActiveWorkbook.Save" 'de hata veriyordu satırı silince normal kayıt almaya başladı. İlginize ve desteğinize teşekkür ederim.

İyi akşamlar diliyorum.

Saygılar,
 
SİBEL70' Alıntı:
Sayın; dentex desteğiniz için teşekkürler.. Bu şekilde sorunsuz çalışıyor.
Sayın; Halit3 kodu dosyada çalıştırdığımda, en üst satırında "ActiveWorkbook.Save" 'de hata veriyordu satırı silince normal kayıt almaya başladı. İlginize ve desteğinize teşekkür ederim.

İyi akşamlar diliyorum.

Saygılar,
Genişletmek için tıkla ...

iyi çalışmalar
 
Sayın dentex,

Verdiğiniz kodları ana dosyama henüz uyarlayabildim. Kayıtta sorun yok. Ancak farklıkaydet komutu verdiğimiz, ana dosyayı kapatıp kopyaladığımız yeni dosyayı açıyor. Kodlara baktım ama hangi satırında bunun tanımlandığını anlayamadım. Farklı kaydet butonuna basıldıktan sonra yeni kaydedilen dosyayı kapatması ve üzerinde çalıştığım ana dosyanın açık kalması için yapmam gereken değişiklik konusunda yardımcı olabilirseniz sevinirim.
Saygılar,
 
Merhaba,
uyguladığımız dosyada bu şekilde olmuyor. Eğer başka bir dosyada uyguluyorsanız, orada tetikleyen kodlar olabilir, saygılar.
 
Merhabalar,

Kodları aşağıdaki şekilde düzenledim;

Sub farklıkaydet()
'arr = Split(Link, "/")
'On Error GoTo son
If Dir("D:\FATURA", vbDirectory) = Empty Then MkDir "D:\FATURA"
kls2 = Year(CDate(Sheets("KAYIT").Range("n1")))

If Dir("D:\FATURA\" & kls2, vbDirectory) = Empty Then MkDir "D:\FATURA\" & kls2

ActiveWorkbook.SaveAs Filename:="D:\FATURA\" & kls2 & "\" & Worksheets("KAYIT").Range("a1").Value & ".xlsm"

son:
If Err.Number > 0 Then
MsgBox Worksheets("KAYIT").Range("a1").Value & " " & "Dosyası Kaydedilemedi!"
Else
MsgBox Worksheets("KAYIT").Range("a1").Value & " " & "Dosyası Başarıyla Kaydedildi!"
End If
Shell "xcopy D:\FATURA\*.* /D /Y /E H:\FATURA.YEDEK"
End Sub



Uyguladığım dosya excel 2007 sorun bundan kaynaklı olabilirmi?
 
Merhaba,
değiştirmiş olduğunuz kodlarla denedim (xp - excel 2003) yine sorun olmadı .
Bu arada ' işaretli kodları silebilirsiniz, testten kalma kodlar, geçersizdir :)
 
Sayın dentex,

Bu durumda sorun excel 2007 de demekki. Kodları excel 2007 de kullanmak durumundayım. Sorunu buton yardımıyla tekrar fatura sayfasını açtırarak çözdüm gibi. ilginize teşekkürler.

Saygılar
 
ekli dosyaya bir bakınız.
 

Ekli dosyalar

Sayın halit3,

Desteğiniz için teşekkürler örnek dosya sorunsuz çalışıyor. İyi bir gün diliyorum.

Saygılar,
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst