Birden fazla dosyayı tek dosyada toplamak

[netkit]

İyi akşamlar;
forumda benzer örneklerini bulmama rağmen kendi örneğime bir türlü uyduramadım.
Ekteki dosyadaki gibi bir klasörde 3253 adet dosyam mevcut.
Örneğin a1 a9 arasındaki dosya isimleri MT_ACIBD 2010 3 aylik dosyasına toplamak istiyorum ama dosyalardaki tarih isimlerine göre.
Yani önce MT_ACIBD 2010 3 aylik dosya açılıp
A sütünuna bir kolon eklenece sonra 6 aylık dosyasından a kolonları seçilip eklenen kolona yapıştırılacak ve tekrar A sütünuna kolon eklenip 9 aylık dan a kolonları seçilip eklenen kolona yapıştırılacak.
MT_ACIBD 2010 6 aylik
MT_ACIBD 2010 9 aylik
MT_ACIBD 2010 12 aylik
MT_ACIBD 2011 3 aylik
MT_ACIBD 2011 6 aylik
MT_ACIBD 2011 9 aylik
MT_ACIBD 2011 12 aylik
MT_ACIBD 2012 3 aylik

bazı dosyalar 9 değil 4 tane
bir türlü mantık kuramadım malesef.
vakti bulup bakabilen olabilir belki diye foruma yazdım.

aşağıdaki kodları bulmuştum ama olmadı malesef.

Option Explicit

Sub dosyaları_birlestir()
Dim fso As Object, f As Object, dosya As String, fls As Object
Dim sonsat1 As Long, sonsat2 As Long, sh As Worksheet, liste()
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.getfolder(ThisWorkbook.Path & "\DOSYALAR").Files
ThisWorkbook.Activate
ThisWorkbook.Sheets("Sheet1").Select
Application.ScreenUpdating = False
Range("A6:F65536").ClearContents
For Each fls In f
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
If fso.GetExtensionName(fls) = "xls" Then
If Workbooks.Open(fls).ReadOnly = True Then Workbooks(fls.Name).Close False
For Each sh In Workbooks(fls.Name).Worksheets
sonsat1 = sh.Cells(65536, "A").End(xlUp).Row
Columns("A:O").Select
Selection.Copy
Next sh
Workbooks(fls.Name).Close False
End If
Columns("A:O").Select
Selection.Insert Shift:=xlToRight
Next fls
ThisWorkbook.Activate
ThisWorkbook.Sheets("Sheet1").Select
Application.ScreenUpdating = True
MsgBox "Diğer dosyalardan veriler aktarıldı." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "T O M S O N"
End Sub

 

[omerceri]

Sn netkit
Tablonu kolaylık olması için biraz değiştirdim.
Veri alma işini örnek dosya olmadığından anlamadım.
Böyle daha kolay olur diye düşündüm, kolay gelsin

 

[netkit]

Sayın omerceri;
ilginize teşekkür ederim. Evet anlatım zor olduğundan yanlış yönlendirmiş oldum

http://youtu.be/bsDEMdX5zak

youtuba video olarak kaydettim eğer yardımcı olmazsa dosyaları yuklerım ama dosyalar cok ve karısık olduğundan gene yanlış yönlenme olmasın diye düşündüm.

birde excel klasörde dosyaları açarken sıralı gitmek yerine sıralama yapınca MT_ACIBD 2010 12 aylik dosyasını açarak başlıyor kandırmak mümkünmü acaba?(1 sayısını öne alıyor)
MT_ACIBD 2010 3 aylik
MT_ACIBD 2010 6 aylik
MT_ACIBD 2010 9 aylik
MT_ACIBD 2010 12 aylik
MT_ACIBD 2011 3 aylik
MT_ACIBD 2011 6 aylik
MT_ACIBD 2011 9 aylik
MT_ACIBD 2011 12 aylik
MT_ACIBD 2012 3 aylik

 

[omerceri]

Sn netkit
Verdiğiniz örnekte tarih olarak en küçük "ACIBD" ait "MT_ACIBD 2010 3 aylik" dosyasını açıp ilk sütuna (A sütununa) altaki dosyalardan sıralamanıza göre bilgi aldırmak istiyorsunuz.
Benim yaptığım listeyi "1 to 3253" döngüsüne sokup, B sütunu boşsa bir işlem yapmayacak dolu ise A sütunundaki dosyayı B sütundaki dosyaya aktaracak. bir mantık kurdum.
yani
For i = 1 to 3253
if Range("B" & i) <> "" Then
AlanDosyaAdı = Range("B" & i)
VerenDosyaAdı = Range("A" & i)
'...........Aktarma kodları
End if
Next

Fakat dosyanızın özelliğini bilmediğimden bu aktarma kodlarını yazamadım.
Eğer "MT_ACIBD 2010 3 aylik" dosyasına bir kaç kayıtlık örnek verip bunu eklerseniz yardımcı olbilirim.

 

[netkit]

Sayın Omerceri;
ilginize teşekkür ederim ama malesef sizin kadar hakim olamadığımdan kopyalayarak birşeyler yapmak istedim ama beceremedim.

dosyayı upload ettim.bu örnekte önce MT_ALCTL 2010 3 aylik.xls dosyasını açıyorum "A" kolonuna sütun ekliyorum sonra MT_ALCTL 2010 6 aylik.xls açıyorum A kolonlarını geçip MT_ALCTL 2010 3 aylik.xls dosyasındaki "A" kolonuna yapıştırıyorum tekrar kolon ekleyip sonraki dosyaya geçiyorum.
3500 dosya olunca çok zaman alıyor makro ile herhalde 1 saatte biter diye düşünüyorum.

not: MT_ALCTL FULL.XLS hepsinin toplanmış halidir diğer dosyalarıda böyle yapmak istiyorum.
MT_ALCTL 2010 3 aylik.xls
MT_ALCTL 2010 6 aylik.xls
MT_ALCTL 2010 9 aylik.xls
MT_ALCTL 2010 12 aylik.xls
MT_ALCTL 2011 3 aylik.xls
MT_ALCTL 2011 6 aylik.xls
MT_ALCTL 2011 9 aylik.xls
MT_ALCTL 2011 12 aylik.xls
MT_ALCTL 2012 3 aylik.xls

 

[halit3]

Aşağıdaki linkde (kapalı dosyadan veri alma 60) bu dosyada sayfa5 de (Bütün Dosyalardan ve sayfalardan kopyalıyarak veri al bu sayfaya yapıştır) bu düğme userform14 e işlem yaptırıyor bir kontrol edin


http://www.excel.web.tr/f117/kapaly-dosyalardan-veri-alma-t68879.html

 

[netkit]

Sayın halit3;
teşekkür ederim.
inanın forumda sizin dosyalarda dahil hepsini indirdim 3 gündür denemedik (kopyala yapıştır değiştir) kod bırakmadım ama malesef başarılı olamadım.
Manuel olarak başladım işlemlere..
ilgilenen herkese teşekkür ederim.

 

[halit3]

Sayın halit3;
teşekkür ederim.
inanın forumda sizin dosyalarda dahil hepsini indirdim 3 gündür denemedik (kopyala yapıştır değiştir) kod bırakmadım ama malesef başarılı olamadım.
Manuel olarak başladım işlemlere..
ilgilenen herkese teşekkür ederim.

Anlıyamadım ilgili linkdeki söylediğim dosya işinizi görmedimi.?

 

[halit3]

Ekli dosyada veri sayfasında (veri alınacak klasördeki dosyaları bul) düğmesine tıklıyarak dosyaları a sutünuna aktarıyor.

Sizin burada yapacağınız sıralamayı kendinize göre yapmanız elle dosya sıralamasını değiştirebilirsiniz.

Diğer taraftan data sayfasındaki veri al düğmesine tıklıyarak veri sayfasındaki resime göre(örnek) yani A ve F sutünları seçilerek iki sutün arası seçenek düğmesi işaretlenerek işlemi yap düğmesine tıklayın dosyaların bulunduğu klasörü seçin

Ben örnek olarak verileri aldırdım her dosyada bir sutün boşluk veriyor dosya veri alma işlemi veri sayfasındaki sıralama doğrultusunda data sayfasından b sutündan başlıyarak veriler alınıyor.

 

[omerceri]

Sn netkit
1- Orjinal bilgilerinizi yedekleyin
2- Tüm dosyalarınız aynı klasörde olsun
3- Bu dosyayı da aynı klasöre alın
4- İlk önce "Dosya İsimlerini Al"a tıklayın (dosya isimlerini alıp, sıralayıp, ilk veri alacak dosyayı belirliyor.)
5- Son olarakta "Bilgi Aktar" a tıklayın.
Umarım işinizi görür.

 

[netkit]

Sayın halit3;
Valla programınız o kadar komplike ki tabiri yerindeyse takla bile atıyorda ben taklaya ayak uyduramadım. bir kaç dene yaptım inanın ben bile ne yaptığımı çözemedim. yoksa eminimki yapıyordur. şimdi sizin örnek dosyanıza bakıcam dosyaya bakınca istediğim olmuş gibi.
dosyayı çekip deneyip sonucu paylaşırım.
çok teşekkür ederim.

Sayın omerceri sizin dosyanızıda aldım teşekkür ederim.Pazar gününüzü benim dosyalarla meşgul olarak geçirdiniz..

 

[netkit]

Sayın halit3;
dosyanız için teşekkür ederim.
sadece klasördeki bütün dosyaları tek dosyada birleştiriyor. İlgili dosyaları ayrı klasörlere koyarak path olarak vererek yapabilirim herhalde kalanı.
çok teşekkür ederim size ve sayın omerceri ye..

 

[tahsinanarat]

Altarnatif olsun diye ekliyorum.

Fazlaca bir zamanımı aldığı için uğraşlarımın boşuna gitmemesi adına bulduğum çözümü ekte sunuyorum. Kodlar Sn. evren hocama ve Sn. Halit3 hocamın kodlarından faydanılarak tasarlanmıştır.
Dosyaların belirttiğiniz sırada alınmasını istiyorsunuz, bunun için öncelikle orjinal dosyanızın bir yedeğini alarak yedek dosyalar üzerinde işlemi yapmanızı talep ediyorum.
1- öncelikle dosya yedeğini YENİ adlı bir klasör içerisinde oluşturacağınız değiştir adlı klasör içine yedeğinizi alıyoruz.
Sonra dosya isimlerini değiştireceğimiz Dosya ismini değiştirme.xls dosyazını açarak Sırasıyla;
-TEMİZLE
-FİHRİST OLUŞTUR (yedek aldığınız dosyayı gösteriyorsunuz)
-SIRAYA KOY
-İSİM DEĞİŞTİR
butonlarına basarak otomatik olarak dosya isimlerine 1 den başlayarak numaralandıracaktır.

2- Sn. evren hocamın hazırladığı dosyaları birleştirme kodları ile hazırladığım MT_ALCTL FULL.xls dosyasını da YENİ adlı bir klasör içerisine kopyalayıp dosyayı çalıştırıyoruz. Dosyaları birleştir butonuna basıyoruz, Hepsi bu kadar
istediğiniz sırada altalta sıralandığını göreceksiniz.

 

[netkit]

Sayın tahsinanarat;

size ve Sayın evren hocamıza teşekkür ediyorum.
Dosyalar büyük ve karışık olduğundan en büyük sorunu açıklamanının zor olması dolayısıyla anlaşılmasının da zor olmasından işlem uzadı.

Dosyalarınızı kullandım ama excel in sıralama mantığından
2010 12 aylik 1
2010 3 aylik 2 şeklinde gitmesi ilk problemim oldu.
dosya sayısı az olunca elle numaraları değiştirerek bu sorunu hallettim.

2 incisi klasöre kopyaladığım dosyaları alt alta kopyalaması oldu.
koptalam A arasını A sütünuna kolon ekleyip yapmasını istiyordum. (Sayın halit3 saolsun bu sorunu halletti),

3 üncüsü Dosya ismini değiştirme dosyasındaki e1 hücresinde formül #DEĞER olarak var umarım bir yeri etkilemiyordur.

Uğraşlarınız için çok teşekkür ederim bu kadarı bile bayağı yol almamı sağladı.

 

[tahsinanarat]

Sn. netkit, verdiğiniz örnek dosyalar doğrultusunda sıralamada herhangi bir hata yok, dosya isimlerinde verdiğiniz örnek haricinde dosya ismi içeriyor ise bu dediğiniz olabilir, örnek dosyaların sıralamasında ve birleştirilmesinde, tekrar denedim herhangi bir sorun olmadı, dosya isimlerinde değişik örnekler varsa gönderin bakalım.

 

[netkit]

Sayın tahsinanarat;

Bir firmanın 3.ay ,6. ay ,9.ay ,12. ay mail bilgileri ayrı ayrı excel olarak mevcut(400 adet farklı firma ve yaklaşık 3600 excel tablosu)
benim amacım bunları tek dosyada yanyana toplamak.
MT_ALCTL 2010 3 aylik MT_ALCTL 2010 6 aylik MT_ALCTL 2010 9 aylik MT_ALCTL 2010 12 aylik MT_ALCTL 2011 3 aylik MT_ALCTL 2011 6 aylik MT_ALCTL 2011 9 aylik MT_ALCTL 2011 12 aylik MT_ALCTL 2012 3 aylik.xls
dosyalarını MT_ALCTL FULL dosyasında yatay olarak birleştirmek istiyorum.
ilk mesajımdaki dosyada dosya listesi mevcuttur. Ayrıca youtube linkinde normalde manuel nasıl yaptığımı capture ettim.

Sizin makroyu çalıştırınca sıralama ekranı ekteki gibi. 12 aylık en üste çıktığından kopyalarken sıralamalar değişiyor.

teamviewer kullanıyorsanız özelden mesajlaşıp ekranı anlatabilirim.
ilginize teşekkür ederim..

http://f1207.hizliresim.com/z/9/9kgyp.jpg

 

[netkit]

İyi akşamlar;
uzun uğraşlar ve sizlerin gönderdiği dosya ve kodlardan derlediğim makro geçici olarak (klasördeki dosyaları 5 er tane bıraktım. dosya isimlerini tarihsiz olarak isimler dosyasına sıraladım ama atlamadan ve for next 5 erli yaparak bu noktaya geldi.
şimdi 9,5,ve daha az olarak makro yapıp özet tablodan dosya isimlerini saydırarak gruplandıracağım. Belki başka arkadaşa lazım olur.
Herkese emeklerinden dolayı teşekkür ederim..






Sub ac()
Dim d3, d4, d5, d6, d7 As String
d3 = "2011 3 aylik"
d4 = "2011 6 aylik"
d5 = "2011 9 aylik"
d6 = "2011 12 aylik"
d7 = "2012 3 aylik"
For I = 2 To 906 Step 5
Windows("isimler.xls").Activate
ad = Range("a" & I).Value
Workbooks.Add
ActiveWorkbook.SaveAs Filename:="I:\BORSA\KAP\Yeni klasör (2)" & "\" & ad + " " + "FULL.xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Windows("isimler.xls").Activate

Workbooks.Open Filename:="I:\BORSA\KAP\Yeni klasör (2)" & "\" & Range("a" & I).Value + " " + d3 + " .xls"
Columns("A").Select
Selection.Copy
Windows(ad + " " + "FULL.xls").Activate
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Columns("A:A").Select 'B
Application.CutCopyMode = False
Selection.Insert Shift:=xlToRight
Windows("isimler.xls").Activate
Workbooks.Open Filename:="I:\BORSA\KAP\Yeni klasör (2)" & "\" & Range("a" & I).Value + " " + d4 + " .xls"
Columns("A").Select
Selection.Copy
Windows(ad + " " + "FULL.xls").Activate
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Columns("A:A").Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlToRight
Windows("isimler.xls").Activate
Workbooks.Open Filename:="I:\BORSA\KAP\Yeni klasör (2)" & "\" & Range("a" & I).Value + " " + d5 + " .xls"
Columns("A").Select
Selection.Copy
Windows(ad + " " + "FULL.xls").Activate
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Columns("A:A").Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlToRight
Windows("isimler.xls").Activate
Workbooks.Open Filename:="I:\BORSA\KAP\Yeni klasör (2)" & "\" & Range("a" & I).Value + " " + d6 + " .xls"
Columns("A").Select
Selection.Copy
Windows(ad + " " + "FULL.xls").Activate
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Columns("A:A").Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlToRight
Windows("isimler.xls").Activate
Workbooks.Open Filename:="I:\BORSA\KAP\Yeni klasör (2)" & "\" & Range("a" & I).Value + " " + d7 + " .xls"
Columns("A").Select
Selection.Copy
Windows(ad + " " + "FULL.xls").Activate
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Cells(1, 1).Select

' Columns("A:A").Select
' Application.CutCopyMode = False
' Selection.Insert Shift:=xlToRight
ActiveWorkbook.Save
ActiveWorkbook.Close
Windows(ad + " " + d3 + " .xls").Activate
ActiveWorkbook.Close
Windows(ad + " " + d4 + " .xls").Activate
ActiveWorkbook.Close
Windows(ad + " " + d5 + " .xls").Activate
ActiveWorkbook.Close
Windows(ad + " " + d6 + " .xls").Activate
ActiveWorkbook.Close
Windows(ad + " " + d7 + " .xls").Activate
ActiveWorkbook.Close
Next
End Sub

 

[omerceri]

sn netkit
eklediğim örnek dosya tüm istediğinizi bir defada yapıyor denemediniz herhalde.

 

[tahsinanarat]

Sn.omerceri, sizin dosyanızı indirip denediğimde;
Range("B" & sıra).Value = Mid(Range("a" & sıra), 4, InStr(1, Range("a" & sıra), "20") - 4)
satırında hata veriyor, bu sebeple sonucu göremedim. Bakabilirmisiniz.

 

[netkit]

Sayın omerceri;
dosyanızı gönderdiğiniz akşam denedim ve cevap yazmıştım ama herhalde hattan düşmüşüm mesajım size gitmemiş malesef tekrardan da bakmadığım için göremedim özür dilerim.
Sizin örnek dosyada şirketin dosyalarını açıp ilk dosyada birleştirip kayıt yapıyordu yani aynı bilgiyi yapıyor dosyaya. birde ismini değiştirmiyordu.
örnek dosyayı ekledim. belki mesajım gitsydi şimdiye bu sorunu çözmüş olurduk eminimki.
kusura bakmayın..

not:Sn tahsinanarat makro sorunsuz çalışıyor bende hata vermiyor.

sn netkit
eklediğim örnek dosya tüm istediğinizi bir defada yapıyor denemediniz herhalde.