• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Farklı excel dosyalarını 1 excel dosyasında alt alta birleştirme.

K

kamerbk

Katılım
7 Temmuz 2010
Mesajlar
7
Excel Vers. ve Dili
2010 enu
Merhabalar,

Elimizde bir programdan çıktı halinde aldığımız excel dosyaları var. Her bir kalem için 1 excel içerisinde 1 tablo oluşturuyor tablo boyutu A1,J36 arasında print çıktısı tam 1 A4 boyutunda, yapmak istediğim şey mesela 10 kalem için tek bir excel tablosunda 10 kalem ürünü birleştirmek ve print çıktısını 10 sayfa haline getirmek.Tüm excel dosyaları aynı içerikte ve her excel de 4 sheet bulunuyor benim için önemli olan sadece Sertifika isimli Sheet.

Yardımlarınız için şimdide teşekkür ederim.
 
Son düzenleme:
excelçweb.tr'ye hoş geldiniz.

aşağıdaki gibi bir şey olabilir.

Kod: 
Sub KitaplardanAynIsimliSayfalar()
'http://www.excel.web.tr/f48/farkly-excel-dosyalaryny-1-excel-dosyasynda-alt-alta-t107142.html#post583780

Dim wb As Workbook, wbyeni As Workbook
Dim ws As Worksheet
Dim kopyala As Range
Dim yol As String, dosyalar As String, dosya() As String
Dim sat As Long, dNo As Long, sNo As Long, calc As Long
Dim ss As Long, i As Long, pbSat As Long

With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .EnableEvents = False
    calc = .Calculation
    .Calculation = xlCalculationManual
End With

yol = "C:\Users\ben\Documents\deneme\sil_suz" 'dosyaların bulunduğu klasörün tam yolu ile değiştir
If Right(yol, 1) <> "\" Then yol = yol & "\"

dosyalar = Dir(yol & "*.xl*")
If dosyalar = "" Then
    MsgBox "Klasörde Excel dosyası yok!", vbOKOnly + vbCritical, "U Y A R I"
    Exit Sub
End If

Do While dosyalar <> ""
    dNo = dNo + 1
    ReDim Preserve dosya(1 To dNo)
    dosya(dNo) = dosyalar
    dosyalar = Dir()
Loop

Set wbyeni = Workbooks.Add(xlWBATWorksheet)
Set ws = wbyeni.Worksheets(1)

sNo = 1
On Error Resume Next
For dNo = LBound(dosya) To UBound(dosya)
    Set wb = Nothing
    If Not wb.Name Like ThisWorkbook.Name And wb.Name Like "tüm_sertifikalar" Then
        Set wb = Workbooks.Open(yol & dosya(dNo))
    End If
    With wb.Worksheets("Sertifika")
        Set kopyala = .Range("A1:J36")
    End With
    sat = kopyala.Rows.Count
    Set nereye = ws.Range("A" & sNo)
    kopyala.Copy
    wbyeni.Activate
    Range("A" & sNo).Select
    ActiveSheet.Paste
    sNo = sNo + sat
    wb.Close savechanges:=False
Next dNo
On Error GoTo 0

pbSat = 36 '"A1:J36" alanı nedeni ile her 36 satırda bir ayrı sayfa olması için.
With ws
    .Columns.AutoFit 'sütun genişliği için. silinebilir.
    .ResetAllPageBreaks
    ss = .Cells(Rows.Count, "A").End(xlUp).Row
    For i = pbSat + 1 To ss Step pbSat
        .HPageBreaks.Add Before:=.Cells(i, 1)
    Next
End With

wbyeni.SaveAs yol & "tüm_sertifikalar", FileFormat:=51
wbyeni.Close

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = calc
End With

End Sub
 
Hocam elinize sağlık çok güzel olmuş tam istediğim gibi, açıklamalar içinde teşekkürler işime yaradı. vb den anlamıyorum o yüzden birşey daha soracağım paste ederken nasıl aynı formatta paste ettire biliriz yeni oluşturduğu dosyaya, birde son olarak macroda yol yerine browse penceresi açtıra bilir miyiz?
 
rica ederim.
Ancak "hoca" değilim; "meraklı"yım sadece.


sayfa ismini "sertifika" olarak görünce formatların da muhafaza edilmek istediğini anlamıştım.
kodu da pratik ve hızlı yöntem yerine bu ihtiyaca göre yazmıştım.

Paste yöntemi formatları da kopyalar, sadece verileri değil. ben denediğimde formatları ile bilikte kopyalıyor.

belki farklı bir husus kastediyorsunuz. örnek dosya eklerseniz bakalım.


sadece klasörü mü seçmek istiyorsunuz, yoksa birleştirilecek dosyalar seçilecek mi?
 
Kusura bakmayın alışkanlıktan dolayı hocam kelimesini kullanıyorum.

Dosyayı ekledim benim için ilk sayfanın Sertifikalar yazan sheet in önemi var ön izleme yapınca gözüken format önemli.

Sizde fark edeceksiniz zaten her excel dosyası aynı eklediğim dosya ile birebir aynı formatta. Sadece Billeştirilecek dosyaları seçmek istiyorum
 

Ekli dosyalar

Son düzenleme:
sütun genişliği istemişsiniz.

dosya açma konusunda bilgi yok. ben kendim ekledim.

klasör ve dosyaları seçmeniz gerekiyor.

bir deneyin, olacak mı...


Kod: 
Sub KitaplardanAynIsimliSayfalar2222()
'http://www.excel.web.tr/f48/farkly-excel-dosyalar_eskiyny-1-excel-dosyasynda-alt-alta-t107142.html#post583780

Dim wb As Workbook, wbyeni As Workbook
Dim ws As Worksheet
Dim kopyala As Range
Dim dosyalar As Variant
Dim sat As Long, sNo As Long, calc As Long
Dim i As Long, j As Long, ss As Long, pbSat As Long

With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .EnableEvents = False
    calc = .Calculation
    .Calculation = xlCalculationManual
End With

yol = "H:\ms_ofis\dennnn\deneme2\"

dosyalar = Application.GetOpenFilename(MultiSelect:=True)

If IsArray(dosyalar) Then
    Set wbyeni = Workbooks.Add(xlWBATWorksheet)
    Set ws = wbyeni.Worksheets(1)
    sNo = 1
    For i = LBound(dosyalar) To UBound(dosyalar)
        Set wb = Nothing
        Set wb = Workbooks.Open(dosyalar(i))
        With wb.Worksheets("Sertifika")
            Set kopyala = .Range("A1:J36")
        End With
        sat = kopyala.Rows.Count
        sut = kopyala.Columns.Count
        Set nereye = ws.Range("A" & sNo)
        kopyala.Copy
        wbyeni.Activate
        With Range("A" & sNo).Resize(sat, sut)
            .PasteSpecial Paste:=xlPasteValues
            .PasteSpecial Paste:=xlPasteFormats
            .PasteSpecial Paste:=xlPasteColumnWidths
        End With
        sNo = sNo + sat
        wb.Close savechanges:=False
    Next i
Else
    MsgBox "Dosya seçilmedi."
End If

pbSat = 36 '"A1:J36" alanı nedeni ile her 36 satırda bir ayrı sayfa olması için.
With ws
    .ResetAllPageBreaks
    ss = .Cells(Rows.Count, "A").End(xlUp).Row
    For j = pbSat + 1 To ss Step pbSat
        .HPageBreaks.Add Before:=.Cells(j, 1)
    Next
    .Range("A1").Select
End With

wbyeni.SaveAs yol & "tüm_sertifikalar", FileFormat:=51
wbyeni.Close

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = calc
End With

End Sub
 
Script gayet güzel çalışıyor Sonunda Run-time error '1004' veriyor ama problem değil sonuç olarak parça halindeki excel dosyalarını birleştiriyor.

İş yazdırmaya geldiğinde parça halindeki excel dosyaları tek sayfa ama parçalar script ile birleştiğinde

mesela 9 sayfa olan parçalar 14 sayfaya çıkıyor çünkü programdan aldığım excel dosyası ekte eklemiştim

ön izlemesi ile birleştikten sonraki ön izleme farklı oluyor. Sanırım sayfada footer ekli o yüzden onu kopyalamıyor ve 1 sayfada 2 sayfa şeklinde gözüküyor.
yani buna yapa bileceğimiz birşey varsa çok makbule geçer.
 
Son düzenleme:
bende bir hata mesajı oluşmadı.

diğer hususlar page setup ile ilgili. boş bir kitap açtığımız için standart ayarlarınız ile açılıyor.

şöyle bir şey olabilir:
mevcut dosyalardan bir tanesi açar, sertifika dışındaki alanları temizler, diğer dosyaları bunun altına kopyalarız.

aşağıdaki kod yüklediğiniz örnek dosyadan 4 tanesini sorunsuz birleştirdi ve tanımlı yazıcımdan 1 nüsha sorunsuz yazdırdı.

Kod: 
Sub KitaplardanAynIsimliSayfalar333()
'http://www.excel.web.tr/f48/farkly-excel-dosyalar_eskiyny-1-excel-dosyasynda-alt-alta-t107142.html#post583780

Dim wb As Workbook, wbyeni As Workbook, ws As Worksheet
Dim kopyala As Range, dosyalar As Variant
Dim sat As Long, sut As Long, i As Long, sNo As Long, calc As Long

With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .EnableEvents = False
    calc = .Calculation
    .Calculation = xlCalculationManual
End With

yol = "H:\ms_ofis\dennnn\deneme2\"

dosyalar = Application.GetOpenFilename(MultiSelect:=True)

If IsArray(dosyalar) Then
    Set wbyeni = Workbooks.Open(dosyalar(LBound(dosyalar)))
    ActiveWindow.View = xlNormalView
    For Each ws In wbyeni.Worksheets
        With ws
            If UCase(.Name) = UCase("Sertifika") Then
                .Range("A1:J36").Value = .Range("A1:J36").Value
                .Columns("K:O").Delete
                With .PageSetup
                    .PrintArea = ""
                    .LeftHeader = ""
                    .CenterHeader = ""
                    .RightHeader = ""
                    .LeftFooter = ""
                    .CenterFooter = ""
                    .RightFooter = ""
                End With
            Else
                .Delete
            End If
        End With
    Next
    Set ws = wbyeni.Worksheets("Sertifika")
    
    sNo = 38
    For i = LBound(dosyalar) + 1 To UBound(dosyalar)
        Set wb = Nothing
        Set wb = Workbooks.Open(dosyalar(i))
        With wb.Worksheets("Sertifika")
            Set kopyala = .Range("A1:J36")
        End With
        sat = kopyala.Rows.Count
        sut = kopyala.Columns.Count
        Set nereye = ws.Range("A" & sNo)
        kopyala.Copy
        wbyeni.Activate
        With Range("A" & sNo).Resize(sat, sut)
            .PasteSpecial Paste:=xlPasteValues
            .PasteSpecial Paste:=xlPasteFormats
        End With
        ActiveSheet.HPageBreaks.Add Before:=Cells(sNo - 1, 1)
        sNo = sNo + sat + 1
        wb.Close savechanges:=False
    Next i
Else
    MsgBox "Dosya seçilmedi."
End If

Range("A1").Select
ActiveSheet.PrintOut 'tanımlı yazıcıdan yazdırmak için; çıktı alınmayacaksa silinebilir.
wbyeni.SaveAs yol & "tüm_sertifikalar", FileFormat:=51
'wbyeni.Close 'kapatmak için başındaki ' silinmelidir.

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = calc
End With

End Sub
 
benimde bir sorum olacak.tek bir excell sayfasında iç içe kitaplar oluşturamazmıyız ?böyle birşey olsa gereksiz dosya çöplüğünden kurtulmuş olurduk.hani yeni bir çalışma kitabı açınca altında sayfa1,sayfa2 diye devam ediyor ya,o sayfalarında hemen altında kitaplar için ayrı bir yer olsa onlar da kitap1 kitap 2 diye devam etse ve bunların hepsini içine alsa süper olurdu.yani ben dosya sayfasından yeni bir dosya açtığımda excell onu farklı bir dosya olarak (kitap1,kitap2... gibi) açıyor ve farklı kaydetmemi istiyor.halbuki ben o dosyanın da son kayıtlı excell sayfamın içinde olması istiyorum bilmem anlatabildim mi?
 
mancubus,

Valla son hali ile mükemmel oldu. Harcadığınız vakit için çok teşekkür ederim.
 
rica ederim.

sadeleştireyim derken değişkenlerden birini silmişim.

bu satırı silerek
Kod: 
Dim kopyala As Range, dosyalar As Variant



yerine
Kod: 
Dim kopyala As Range, [COLOR="Red"]nereye As Range,[/COLOR] dosyalar As Variant
satırını eklersek iyi olur.
 
bende PDF eklendisi buldum simdi güzel oldu direk PDF yapıyor.

Kod: 
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FNAME, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=False

Son hali bu şekilde.
Kod: 
Sub KitaplardanAynIsimliSayfalar333()
'http://www.excel.web.tr/f48/farkly-excel-dosyalar_eskiyny-1-excel-dosyasynda-alt-alta-t107142.html#post583780

Dim wb As Workbook, wbyeni As Workbook, ws As Worksheet
Dim kopyala As Range, nereye As Range, dosyalar As Variant
Dim sat As Long, sut As Long, i As Long, sNo As Long, calc As Long

With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .EnableEvents = False
    calc = .Calculation
    .Calculation = xlCalculationManual
End With

yol = "H:\ms_ofis\dennnn\deneme2\"

dosyalar = Application.GetOpenFilename(MultiSelect:=True)

If IsArray(dosyalar) Then
    Set wbyeni = Workbooks.Open(dosyalar(LBound(dosyalar)))
    ActiveWindow.View = xlNormalView
    For Each ws In wbyeni.Worksheets
        With ws
            If UCase(.Name) = UCase("Sertifika") Then
                .Range("A1:J36").Value = .Range("A1:J36").Value
                .Columns("K:O").Delete
                With .PageSetup
                    .PrintArea = ""
                    .LeftHeader = ""
                    .CenterHeader = ""
                    .RightHeader = ""
                    .LeftFooter = ""
                    .CenterFooter = ""
                    .RightFooter = ""
                End With
            Else
                .Delete
            End If
        End With
    Next
    Set ws = wbyeni.Worksheets("Sertifika")
    
    sNo = 38
    For i = LBound(dosyalar) + 1 To UBound(dosyalar)
        Set wb = Nothing
        Set wb = Workbooks.Open(dosyalar(i))
        With wb.Worksheets("Sertifika")
            Set kopyala = .Range("A1:J36")
        End With
        sat = kopyala.Rows.Count
        sut = kopyala.Columns.Count
        Set nereye = ws.Range("A" & sNo)
        kopyala.Copy
        wbyeni.Activate
        With Range("A" & sNo).Resize(sat, sut)
            .PasteSpecial Paste:=xlPasteValues
            .PasteSpecial Paste:=xlPasteFormats
        End With
        ActiveSheet.HPageBreaks.Add Before:=Cells(sNo - 1, 1)
        sNo = sNo + sat + 1
        wb.Close savechanges:=False
    Next i
Else
    MsgBox "Dosya seçilmedi."
End If
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FNAME, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=False

Range("A1").Select
'ActiveSheet.PrintOut 'tanımlı yazıcıdan yazdırmak için; çıktı alınmayacaksa silinebilir.
'wbyeni.SaveAs yol & "tüm_sertifikalar", FileFormat:=51
wbyeni.Close 'kapatmak için başındaki ' silinmelidir.

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = calc
End With

End Sub

Son olarak excel dosyalarındaki resimleri ilk sayfaya paste ediyor fakat sonraki sayfalarda resim eklemiyor. firma logosu var normalde excelde.
 
Son düzenleme:
merhabalar, forumlardan yola çıkarak makroyu düzenlemeye çalıştım ancak sağlıklı çalıştıramadım. eklediğim dosya için bana yardımcı olabilirmisiniz.
Veri Al dosyasına (klasörün içindeki dosyalardaki verileri almak istiyorum) ilgili hücrelerin altına boşluk olmadan sıralasın istiyorum. ilk sütun için bunu yapıyor, ancak diğer sütunlar için de yaptırmak istiyorum, yardımlarınız için şimdiden teşekkür ederim.
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst