Sayfaları birleştirme

[sefa88]

Merhaba,
Çalışma kitabında 3 tane sayfa var. Bunları birleştirmek istiyorum. Ama başlıklar değişkenlikler gösteriyor. Yeni bir başlık gelebiliyor veya sıralama değişiyor.

Dosyayı eklemek istiyorum ancak nasıl yapacağımı bilemiyorum.

Teşekkürler.

 

[Ömer]

Merhaba,

Herhangi bir paylaşım sitesine ekleyebilirsiniz.

www.dosya.tc

gibi.

.

 

[sefa88]

Dosya yüklendi

http://www.dosya.tc/server/niiysh/Birlestirme_Ornek.rar.html

Dosyayı yükledim.
Bir kontrol eder misiniz?

Teşekkürler.

 

[Ömer]

Eğer başlık isimleri değişkense bunu koda ilave ederim. Fakat gördüğüm kadarıyla başlık isimleri sabit, sadece her sayada yerleri karışık ve bazı sayfaların başlıkları diğer sayfada yok.
Siz tüm isimleri 1+2+3.Sayfalar sayfasının 1. satırına diğer sayfalardaki yada bildiğiniz tüm başlık isimlerini tekrar etmeden sırasını siz belirleyerek yazın.

Daha sonra aşağıdaki kodları çalıştırdığınızda istediğiniz olacaktır.

Sub Sayfalari_Birlestir()

    Dim sut_a As Integer, i As Byte, son_a As Long
    Dim j As Integer, c As Range, sut As Integer, son_s As Long

    Application.ScreenUpdating = False
    Sheets([COLOR="Red"]"1+2+3.Sayfalar[/COLOR]").Select 'ana sayfanın adı
    
    sut_a = Cells(1, Columns.Count).End(xlToLeft).Column
    Range(Cells(2, 1), Cells(Rows.Count, sut_a)).ClearContents
    
    For i = 1 To Worksheets.Count
        With Sheets(i)
            If .Name <> ActiveSheet.Name Then
                son_a = Cells.Find("*", , , , xlByRows, xlPrevious).Row + 1
                For j = 1 To sut_a
                    Set c = .Rows(1).Find(Cells(1, j), , xlValues, xlWhole)
                    If Not c Is Nothing Then
                        sut = c.Column
                        son_s = .Cells(Rows.Count, sut).End(xlUp).Row
                        .Cells(2, sut).Resize(son_s, 1).Copy Cells(son_a, j)
                    End If
                Next j
            End If
        End With
    Next i
    
    Cells.EntireColumn.AutoFit
    Cells.HorizontalAlignment = xlCenter
                   
    Application.ScreenUpdating = True
                                        
                    
End Sub

.

 

[sefa88]

Merhaba,
Teşekkür ederim süper olmuş.
Tam istediğim gibi eline sağlık.
Çok sağol.

Teşekkürler.