Birden çok kapalı dosyaya veri işlemek

[cimbom05]

İyi günler,
İşim gereği kullandığım Sipariş.xls adında bir Excel dosyam var. Bu dosyaya yıl içinde gelen tüm siparişler işlenmektedir. Sipariş dosyasındaki her firma için firma ismi ile oluşturulmuş Excel dosyaları mevcuttur. Yapmak istediğim şey, Sipariş dosyasına eklenen her bir sipariş için o firmanın dosyasına siparişlerin örnekte olduğu gibi listelenmesi. Yapılabilir ise sipariş açılan bir bir firma için oluşturulmuş bir dosya yok ise uyarı vermesi veya oluşturması.
Makrolara sizler gibi hakim olamadığımdan dolayı olabilecek bir şey mi istiyorum yoksa bu çok saçma bir şeymi bilemiyorum. Ekte istediğimi içeren bir örnek çalışma gönderiyorum. Yardımlarınız için teşekkür ederim.

 

[cimbom05]

İyi günler
Bu konu ile ilgili yardımcı olabilecek arkadaşlar yok sanırım.

 

[Korhan Ayhan]

Selamlar,

Ekteki örnek dosyayı incelermisiniz.

Kod şu şekilde çalışıyor.

İlk olarak "Sipariş" isimli dosyanızın bulunduğu klasörü kontrol ediyor eğer "FİRMALAR" isimli klasör yoksa bu klasörü oluşturduktan Firma Adı bilgilerine ait dosya olup olmadığı kontrol ediliyor eğer firma adına ait dosya yoksa yeni bir dosya açılıp bilgiler aktarılıyor. Eğer dosya varsa ilgili dosya açılıp bilgiler aktarılıyor.

Umarım faydası olur.


Uygulanan kod;

Option Explicit
 
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 & "\FİRMALAR"
    
    If Not CreateObject("Scripting.FileSystemObject").FolderExists(Dosya_Yolu) Then
    CreateObject("Scripting.FileSystemObject").CreateFolder (Dosya_Yolu)
    End If
    
    Veri_Dosyası.Sheets("Sipariş Listesi").Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Veri_Dosyası.Sheets("Sipariş Listesi").Range("IV1"), Unique:=True
    
    For X = 2 To Veri_Dosyası.Sheets("Sipariş Listesi").Range("IV65536").End(3).Row
    
    Dosya = Dosya_Yolu & "\" & Veri_Dosyası.Sheets("Sipariş Listesi").Cells(X, 256) & ".xls"
    
    If Dir(Dosya, vbNormal) = "" Then
    Set Yeni_Dosya = Workbooks.Add(1)
    Yeni_Dosya.ActiveSheet.Name = Veri_Dosyası.Sheets("Sipariş Listesi").Cells(X, 256)
    Yeni_Dosya.SaveAs Filename:=Dosya
    Veri_Dosyası.Sheets("Sipariş Listesi").Range("A1").AutoFilter Field:=2, Criteria1:=Replace(Yeni_Dosya.Name, ".xls", "")
    Veri_Dosyası.Sheets("Sipariş Listesi").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("Sipariş Listesi").Range("A1").AutoFilter Field:=2, Criteria1:=Replace(Kaynak_Dosya.Name, ".xls", "")
    Son_Satır = Veri_Dosyası.Sheets("Sipariş Listesi").Range("A65536").End(3).Row
    If Son_Satır > 1 Then
    Veri_Dosyası.Sheets("Sipariş Listesi").Range("A2:D" & Son_Satır).Copy Cells(Satır, 1)
    Cells.EntireColumn.AutoFit
    End If
    
    Kaynak_Dosya.Close True
    
    End If
        
    Next
    Veri_Dosyası.Sheets("Sipariş Listesi").Range("A1").AutoFilter
    Veri_Dosyası.Sheets("Sipariş Listesi").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

 

[cimbom05]

Sayın Korhan Ayhan çok teşekkür ederim. İstediğim tam olarak buydu. Mükemmel olmuş. Sizden almış olduğum ikinci cevap ve ikiside tam isabetli. Demekki boşuna Uzman olunmuyormuş.

http://www.excel.web.tr/f48/textbox-ve-duseyara-t61237/sayfa2.html

adresinde Textbox ve düşeyara ile ilgili konuyada sizden bir cevap gelirse bu konu da kapanır. Her şey için teşekkür ederim.

 

[ms_6647]

merhabalar

Gerçekten çok güzel bir çalışma benim bir sorum olacak listedeki verileri ayrı excel dosyası olarak oluşturduktan sonra ayrı ayrı oluşturulan excel dosyalarını tekrar bir liste haline getirme imkanımız varmı?

 

[baydeniro]

Merhaba. Çok zaman geçmiş ancak ben de Sn. Korhan Ayhan'a bir teşekkür etmek istiyorum. Sağolun, var olun.