Exel Birleştirme

[RyouMax]

herkese merhabalar. şimdi 10 tane exel dosyam var bunlar aynı şablonda ama farklı verileri içeriyor. bunları tek bir exelde sayfa sayfa toplamam gerekiyor.bunun kolay bi yolu varmıdır. şimdiden teşekkürler.

 

[Asri]

Daha hızlı cevap alabilmek için, iki farklı veri içeren iki dosyayı dosya.tc yada dosya.co ya yükleyip link ekleyiniz.

 

[RyouMax]

http://s3.dosya.tc/server9/5egy5p/20161209.rar.html buradaki örnek exeller tek bir exelde sayfa sayfa olmalıdır. alt alta değil!

 

[PLİNT]

Merhaba
Ek dosyayı deneyiniz.
Kod bulunan dosya; sayfaları alınacak dosyaların olduğu klasörün yanında olmalı.
http://s3.dosya.tc/server10/kfjxrm/20161209.zip.html

 

[RyouMax]

Aralarda açılan fazla sayfalar ne için onu anlayamadım.onlar biraz zorluk çıkarıyor.Proje ise gerçekten istediğim gibi olmuş.Teşekkür ederim.

 

[Asri]

Alternatif ;

Bir klasör ve onun altındaki tüm klasörlerde bulunan .xlsx ve .xls uzantılı dosyalardaki bütün sayfaları tek bir dosyada toplar.
Sonuc Dosyası.xlsx programın bulunduğu klasörde oluşturulur.
Birleştirilecek dosyalar programdan farklı bir klasörde olmalıdır.

http://www.excel.web.tr/f52/tum-excel-dosyalary-tek-dosyada-t160842.html

 

[PLİNT]

Aralarda açılan fazla sayfalar ne için onu anlayamadım.

Merhaba
Eklediğiniz örnek dosyalarda bir tanesi gizli; iki sayfa bulunuyordu,fazla dediğiniz bu gizli sayfalar.
Sanırım sn.asri'nin örneğide bütün sayfalar için
Sadece birinci sayfa gelecekse aşağıdaki gibi deneyin.
http://s3.dosya.tc/server10/r2txt2/20161209.zip.html

[SIZE="2"]Private Sub CommandButton1_Click()
Dim wb As Workbook, sh As Integer
Dim ds, f, dc, dosya, sheet
Dim h As String
Set wb = ThisWorkbook
Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.GetFolder(ThisWorkbook.Path & "\20161209")
Set dc = f.Files
For Each dosya In dc
Workbooks.Open dosya
h = Split(dosya.Name, ".")(UBound(Split(dosya.Name, ".")) - 1)
For Each sheet In Workbooks(h).Worksheets
    sh = wb.Worksheets.Count
    Workbooks(h).Worksheets(sheet.Name).Copy _
    after:=wb.Worksheets(sh)
    Exit For
Next sheet
Workbooks(h).Close savechanges:=False
Next
End Sub[/SIZE]

 

[RyouMax]

merhabalar. dosyayı ve kodları denedim bende çalışmadı ne yazıkki. runtime hatası verdi.

 

[PLİNT]

merhabalar. dosyayı ve kodları denedim bende çalışmadı ne yazıkki. runtime hatası verdi.

Merhaba
Run Time 76 hatası varsa klasör bulunamamış, başka klasör içindeki dosyalar
için kullandıysanız kodların içinde bulunan klasör adını değişmelisiniz

Set f = ds.GetFolder(ThisWorkbook.Path & "\[COLOR="Red"]20161209[/COLOR]")

http://i.hizliresim.com/adz2yR.gif

 

[RyouMax]

evet sizde istediğim gibi çalışıyor. klasör ismini değiştirmedim normalde açması gerekirken
"runtime error'9'"
SUBSCRİPT OUT OF RANGE
hatası alıyorum.Acaba bilgisayardan mı kaynaklı diye arkadaşımda denedim ondada aynı hatayı verdi.

 

[PLİNT]

evet sizde istediğim gibi çalışıyor. klasör ismini değiştirmedim normalde açması gerekirken
"runtime error'9'"
SUBSCRİPT OUT OF RANGE
hatası alıyorum.Acaba bilgisayardan mı kaynaklı diye arkadaşımda denedim ondada aynı hatayı verdi.

Merhaba
Aşağıdaki gibi değiştirip deneyelim
Kırmızı bölüm gizli sayfa varsa atlasın,
eğer gelmesi gereken sayfa (gizli hariç) bir den fazla ise mavi bölümü silin.

[SIZE="2"]Private Sub CommandButton1_Click()
Dim wb As Workbook, sh, s As Integer
Dim ds, f, dc, dosya, sheet
Dim h As String
Set wb = ThisWorkbook
Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.GetFolder(ThisWorkbook.Path & "\20161209")
Set dc = f.Files
For Each dosya In dc
If Left(Split(dosya.Name, ".")(UBound(Split(dosya.Name, "."))), 3) = "xls" Then
Workbooks.Open dosya
h = Split(dosya.Name, ".")(UBound(Split(dosya.Name, ".")) - 1)
Application.ScreenUpdating = False
For Each sheet In Workbooks(h).Worksheets
 [COLOR="Red"]If Workbooks(h).Worksheets(sheet.Name).Visible = True Then[/COLOR]
    sh = wb.Worksheets.Count
    Workbooks(h).Worksheets(sheet.Name).Copy _
    after:=wb.Worksheets(sh)
  [COLOR="Blue"]  Exit For[/COLOR]
    [COLOR="Red"]End If[/COLOR]
Next sheet
Application.ScreenUpdating = True
Workbooks(h).Close savechanges:=False
End If
Next
End Sub[/SIZE]

 

[RyouMax]

merhaba sn plint. istediğinizi yaptım yine aynı hatayı alıyorum.isterseniz mail bırakayım ordan konuşalım.Ayrıca ilk gönderdiğiniz proje çalışmıştı. şu gizli dosyalarıda gösteren proje.O projeye gizli varsa atlasın ı ekleyemiyor muyuz ?