Tarih ile aktarma

[mbattal]

Arkadaşlar merhaba,
Aşağıdaki kodu forumda bulup kendime uyarlamaya çalıştım fakat sizlerin yardımına ihtiyacım var.
Bu kod sayesinde İŞ EMİRLERİ klasörü içinde dosya oluşturuyorum dosyanın ismi oluşturulan tarih oluyor (örn. 28.01.2011 gibi) fakat isim tarih olunca geçici sayfasının içerisindeki verileri aktarmıyor. Başka isim verdiğimde sorun çıkmıyor. Dosyanın isminin tarih olması benim için önemli yardımcı olabilirmisiniz.
Saygılarımla

EK'te klasörümü paylaştım.

Sub SİPARİŞLERİ_AKTAR()
Dim Veri_Dosyası As Workbook, Dosya As String, Kaynak_Dosya As Workbook
Dim Dosya_Yolu As String, Satır As Long, Son_Satır As Long
Dim X As Long, Yeni_Dosya As Workbook

On Error GoTo Son

Application.ScreenUpdating = False

Set Veri_Dosyası = ThisWorkbook

Dosya_Yolu = Veri_Dosyası.Path & "\İŞ EMİRLERİ"

If Not CreateObject("Scripting.FileSystemObject").FolderExists(Dosya_Yolu) Then
CreateObject("Scripting.FileSystemObject").CreateFolder (Dosya_Yolu)
End If

Veri_Dosyası.Sheets("geçici").Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Veri_Dosyası.Sheets("geçici").Range("IV1"), Unique:=True

For X = 2 To Veri_Dosyası.Sheets("geçici").Range("IV65536").End(3).Row

Dosya = Dosya_Yolu & "\" & Veri_Dosyası.Sheets("geçici").Cells(X, 256) & ".xls"

If Dir(Dosya, vbNormal) = "" Then
Set Yeni_Dosya = Workbooks.Add(1)
Yeni_Dosya.ActiveSheet.Name = Veri_Dosyası.Sheets("geçici").Cells(X, 256)
Yeni_Dosya.SaveAs Filename:=Dosya
Veri_Dosyası.Sheets("geçici").Range("A1").AutoFilter Field:=2, Criteria1:=Replace(Yeni_Dosya.Name, ".xls", "")
Veri_Dosyası.Sheets("geçici").Range("A1").CurrentRegion.Copy Yeni_Dosya.ActiveSheet.Cells(1, 1)
Yeni_Dosya.Close True

Else

Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)

Satır = [A65536].End(3).Row + 1

Veri_Dosyası.Sheets("geçici").Range("A1").AutoFilter Field:=2, Criteria1:=Replace(Kaynak_Dosya.Name, ".xls", "")
Son_Satır = Veri_Dosyası.Sheets("geçici").Range("A65536").End(3).Row
If Son_Satır > 1 Then
Veri_Dosyası.Sheets("geçici").Range("A2:L" & Son_Satır).Copy Cells(Satır, 1)
Cells.EntireColumn.AutoFit
End If

Kaynak_Dosya.Close True

End If

Next
Veri_Dosyası.Sheets("geçici").Range("A1").AutoFilter
Veri_Dosyası.Sheets("geçici").Range("IV:IV").ClearContents
Application.ScreenUpdating = True

MsgBox "İşleminiz tamamlanmıştır.", vbInformation
Exit Sub

Son:
Application.ScreenUpdating = True
MsgBox "Dosya bulunamamıştır !", vbCritical, "Dikkat !"

End Sub

 

[mbattal]

Arkadaşlar bir çözüm bulamazmıyız ?

 

[mbattal]

Çözümü yokmu arkadaşlar ?
Benim için çok önemli