Makro ile dosya kopyalamak

[gnorar]

Arkadaşlar bir excel dosyasının kopyasını dosya içerisine yazılacak bir makro ile masa üstünde oluşturmak istiyorum. Ancak masa üstünde aynı adlı dosya varsa excel beni uyarsın ve koptalama işini yapmasın. Makro için yardımlarınızı bekliyorum.

 

[truvali27m]

Arkadaşlar bir excel dosyasının kopyasını dosya içerisine yazılacak bir makro ile masa üstünde oluşturmak istiyorum. Ancak masa üstünde aynı adlı dosya varsa excel beni uyarsın ve koptalama işini yapmasın. Makro için yardımlarınızı bekliyorum.

aşağıdaki kod basit bir kopyalama kodu.Eğer aynı adda dosya varsa uyarı veriyor değiştirilsin mi diye,hayır dersen kaydetmiyor eğer aynı adlı dosya yoksa da kaydediyor.

Sub farkli_kaydet()
On Error GoTo 10
ActiveWorkbook.SaveAs
ActiveWorkbook.Close
10
End Sub

 

[gnorar]

Teşekkürler, ancak benim yazdığım makroda yeni bir kitap açılıp ana dosyadaki bazı veriler yedek dosyasına gönderiliyor ve kaydediliyor. Sizin makro işe yarıyor ancak var olan dosya uyarısı verirken benim kodlardan kaynaklı yeni bir excel kitabı açıyor ve açık kalıyor. Bunun önüne nası geçeriz

 

[Zeki Gürsoy]

sub kaydet ()
if dir(environ("userprofile") & "\Desktop\" & thisworkbook.name) <>"" then exit sub
thisworkbook.savecopyas environ("userprofile") & "\Desktop\" & thisworkbook.name
end sub

 

[gnorar]

İlginize Teşekkürler. Ancak sorunumu daha açık belirteyim kodun başlangıcını yazayım:

Sub Kopya()
Dim i, j As String
i = ActiveWorkbook.Name
Set fs = Application.FileSearch
With fs
.LookIn = "C:\"
.Filename = "MalzemeListesi.xls"
If .Execute > 0 Then
MsgBox ("C:\'de MalzemeListesi.xls dosyası zaten var!")
Else
ChDir "C:\"
Set NewBook = Workbooks.Add
With NewBook
.Title = "MalzemeListesi"
.SaveAs Filename:="MalzemeListesi.xls"
End With

Burada sorun Ofis 2007'den itibaren Application.FileSearch komutunun desteklenmemesi. Bu sorunu nasıl aşabilirim?

 

[omerceri]

aşağıdaki kodu kendinize uyarlayın
Dim fs, f, f1, fc
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(Application.Path)
Set fc = f.Files
For Each f1 In fc
msgbox f1.Name

Next



End Sub

 

[omerceri]

Eğer bir yazım hatası yapmamışsam size uyarlanmış şekli aşağıda

Dim fs, f, f1, fc
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder( "C:\")
Set fc = f.Files
a = 0
For Each f1 In fc
if f1.Name = MalzemeListesi.xls" Then
MsgBox ("C:\'de MalzemeListesi.xls dosyası zaten var!")
a = a+1
End if
Next
if a = 0 Then
ChDir "C:\"
Set NewBook = Workbooks.Add
With NewBook
.Title = "MalzemeListesi"
.SaveAs Filename:="MalzemeListesi.xls"
End With
End if

End Sub

 

[gnorar]

Sn. omerceri ufak bir yazım hatasını düzelterek kodu çalıştırdım. Teşekkür ederim.