Dosyadan Yeni Dosyalar Oluşturmak

[Necdet]

Merhaba Arkadaşlar,

Her ay bankalardan ödeme bilgileri excel formatında gelmekte. Tabi bu ödeme bilgileri tüm türkiyeden geldiği için dosyalar oldukça büyük,
bankalar bu büyük dosyayı 3-4 excel sayfasında gönderiyorlar. Dolayısı ile biz bu bilgileri ilgili proje bazında toplayıp tek bir excel dosyası yaparak Oracle veri tabanına atıyoruz. Dolayısı ile tek dosyadan 150 ye yakın dosya oluşturmak zorundayız.
Fakat her ay bu işlemi manuel yapmak baya işimizi zorlaştırıyor.

Dosya yapısından sözedeyim : A sütunu ilgili projeleri içeriyor, diğer sütunlarda ise ayrıntılı bilgiler var. A sütunu proje bazında sıralı oluyor.
Benim yapmak istediğim proje(ler) adı ile yeni bir dosya(lar) oluşturmak (tabi istediğim directory de). Yalnız şöyle bir sorun çıkabilir, yukarıda da anlattığım şekilde bankalar satır sayısına bakarak dosyaları böldükleri için, bir başka dosyada da aynı proje kodu olabilmekte.
Bunun için makro örneğini siz dostlardan rica ediyorum.
Þimdiden emeği geçecek olanlara ve üzerinde kafa yoracak olanlara teşekkür ederim. Ã?rnek bir dosyayı ekte sunuyorum.
İyi Çalışmalar
[/code][/list]

 

[Levent Menteşoğlu]

Ekteki dosyayı inceleyin. Kod aşağıda verilmiştir. Farklı mantıklarla daha kısa bir kod tasarlamakta mümkündür. Dosyadaki kodu çalıştırmadan önce C nin altında aktarma isimli bir klasör oluşturun. Kod öncelikle klasörü inceleyerek aynı isimli dosya olup olmadığını araştırıyor, eğer bulursa verileri bu dosyaya kaydediyor, eğer mevcut değilse aynı isimle bir dosya oluşturup verileri bu dosyaya kaydediyor. "aktarma" isimli klasörü oluşturduktan sonra ekli dosyada bulunan butona basın. Daha sonra "aktarma" isimli klasöre bakarsanız dosyaları göreceksiniz. Dosyaları açarak inceleyin. Eğer veri sayınız çok fazla ise kodun çalışmasınında çok uzun bir zaman alacağınıda belirtmek istiyorum.

[vb:1:b47f4c4d84]Sub aktar()
On Error Resume Next
Application.ScreenUpdating = False
sonsat = [a65536].End(xlUp).Row
Range("A2" & sonsat).Sort Key1:=[a2]
For a = 2 To sonsat
ad = Cells(a - 1, 1).Value & ".xls"
say = WorksheetFunction.CountA(Workbooks(ad).Sheets(1).Columns(1))
If Cells(a, 1) <> Cells(a - 1, 1) Then
b = CreateObject("Scripting.FileSystemObject").FileExists("C:\aktarma\" & Cells(a, 1).Value & ".xls")
dosya = Cells(a, 1).Value & ".xls"
If b = True Then
Workbooks(ad).Save
Workbooks(ad).Close
Workbooks.Open Filename:="C:\aktarma\" & Cells(a, 1).Value
Windows("deneme.xls").Activate
say2 = WorksheetFunction.CountA(Workbooks(dosya).Sheets(1).Columns(1))
For c = 2 To 4
Workbooks(dosya).Sheets(1).Cells(say2 + 1, c - 1) = Cells(a, c).Value
Next
Else
Workbooks(ad).Save
Workbooks(ad).Close
Workbooks.Add.SaveAs Filename:="C:\aktarma\" & Cells(a, 1).Value
Windows("deneme.xls").Activate
say2 = WorksheetFunction.CountA(Workbooks(dosya).Sheets(1).Columns(1))
For c = 2 To 4
Workbooks(dosya).Sheets(1).Cells(say2 + 1, c - 1) = Cells(a, c).Value
Next
End If
End If
For c = 2 To 4
Workbooks(ad).Sheets(1).Cells(say + 1, c - 1) = Cells(a, c).Value
Next
Next
Workbooks(ad).Save
Workbooks(ad).Close
End Sub

[/vb:1:b47f4c4d84]

 

[Necdet]

Sayın leventm,
Çok teşekkür ederim, elinize bilginize sağlık, tam istediğim gibi olmuş. Evet dosyalar baya büyük 50000 satır civarında, zaman alması önemli değil, benim işimi baya kolaylaştırdınız.
Sizden bir isteğim olabilir mi, dosyaları çok güzel aktarıyor ama başlıkta olsaydı çok daha mükemmel olurdu. Tekrar Teşekkür ederim. (Ne yalan söyleyim, içime bu makroyu sizin yazağınız doğmuştu ve nitekim de öyle oldu )

 

[Levent Menteşoğlu]

Rica ederim. Başlık satırı için kodu aşağıdaki ile değiştirerek deneyin.

[vb:1:886380425e]Sub aktar()
On Error Resume Next
Application.ScreenUpdating = False
sonsat = [a65536].End(xlUp).Row
Range("A2" & sonsat).Sort Key1:=[a2]
For a = 2 To sonsat
ad = Cells(a - 1, 1).Value & ".xls"
say = WorksheetFunction.CountA(Workbooks(ad).Sheets(1).Columns(1))
If Cells(a, 1) <> Cells(a - 1, 1) Then
b = CreateObject("Scripting.FileSystemObject").FileExists("C:\aktarma\" & Cells(a, 1).Value & ".xls")
dosya = Cells(a, 1).Value & ".xls"
If b = True Then
Workbooks(ad).Save
Workbooks(ad).Close
Workbooks.Open Filename:="C:\aktarma\" & Cells(a, 1).Value
Windows("deneme.xls").Activate
say2 = WorksheetFunction.CountA(Workbooks(dosya).Sheets(1).Columns(1))
For c = 2 To 4
Workbooks(dosya).Sheets(1).Cells(say2 + 1, c - 1) = Cells(a, c).Value
Next
Else
Workbooks(ad).Save
Workbooks(ad).Close
Workbooks.Add.SaveAs Filename:="C:\aktarma\" & Cells(a, 1).Value
Windows("deneme.xls").Activate
say2 = WorksheetFunction.CountA(Workbooks(dosya).Sheets(1).Columns(1))
If say2 = 0 Then
For d = 2 To 4
Workbooks(dosya).Sheets(1).Cells(1, d - 1) = Cells(1, d).Value
Next
say2 = 1
End If
For c = 2 To 4
Workbooks(dosya).Sheets(1).Cells(say2 + 1, c - 1) = Cells(a, c).Value
Next
End If
End If
For c = 2 To 4
Workbooks(ad).Sheets(1).Cells(say + 1, c - 1) = Cells(a, c).Value
Next
Next
Workbooks(ad).Save
Workbooks(ad).Close
End Sub

[/vb:1:886380425e]

 

[Necdet]

Sayın leventm Bey,

Çok teşekkür ederim.