Soru Sayfaları Alt Alta Birleştirme Makrosu

[bulentkars]

Arkadaşlar Merhaba;

Aşağıdaki kod ile çalışma kitabında aynı formatta olan tüm sayfaları birleştiriyorum.
Burada bir kaç sorun var çözemedim yardımcı olabilirseniz sevinirim. Şimdiden Teşekkürler.

1- Sayfaları birleştirirken her sayfasının başlığını kopyalıyor. ( Ben sadece tek başlık gelmesini istiyorum.)
2 - Birleştirme yaparken örneğin 2 sayfada aynı formatta veri var ancak birleştirmeyi yaparken sanki 3 sayfaymış gibi birleştirme yapıyor. ( Kaç sayfa varsa o sayfaları birleştirecek.)
3 - Makro çalışırken yeni bir sayfa oluşturup işlemi yapıyor. ( Yeni oluşan sayfa adını "Tüm Sayfalar" isminde değişecek.

Sub Tum_sayfaları_Birlestir()

Dim sh As Variant
Dim son As Long, anason As Long
Dim ws As Worksheet, wsAna As Worksheet

Sheets.Add After:=ActiveSheet 'Yeni Sayfa Oluştur.

Set wsAna = ActiveSheet

For Each sh In Worksheets
anason = wsAna.Cells(Rows.Count, 1).End(xlUp).Row

Set ws = Worksheets(sh.Name)
son = ws.Cells(Rows.Count, 1).End(xlUp).Row
ws.Range("A1:XFD" & son).Copy wsAna.Range("A" & anason)
Cells.EntireColumn.AutoFit

Next
End Sub

 

[Muzaffer Ali]

Merhaba.

Sub Tum_sayfaları_Birlestir()
    
    Dim sh As Worksheet
    Dim wsAna As Worksheet
    Dim son As Long, anason As Long
    
    Set wsAna = Sheets.Add(After:=ActiveSheet)    'Yeni Sayfa Oluştur.
    ActiveSheet.Name = "Tüm Sayfalar"

    
    For Each sh In Worksheets
        If Not sh.Name = "Tüm Sayfalar" Then
            anason = wsAna.Cells(Rows.Count, 1).End(xlUp).Row
            son = sh.Cells(Rows.Count, 1).End(xlUp).Row
            sh.Range("A1:XFD" & son).Copy wsAna.Range("A" & anason)
        End If
    Next
    Cells.EntireColumn.AutoFit
End Sub

 

[Necdet]

Merhaba,
2. maddeyi anlamadım.
Örnek dosya eklerseniz anlaşılması kolaylaşır.

Yine de bir şeyler yaptım. Tüm Sayfalar varsa içini siler, sonra aktarır. Yoksa Açar.

Sub Birlestir()

Dim arr As Variant, _
    i   As Long, _
    adt As Integer, _
    ws  As Worksheet, _
    sh  As Worksheet, _
    syf As String

Application.ScreenUpdating = True

syf = "Tüm Sayfalar"

If SayfaVar(syf) Then
    Sheets("Tüm Sayfalar").UsedRange.ClearContents
Else
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = syf
End If

Set ws = Sheets(syf)

For Each sh In Worksheets
    If Not sh.Name = ws.Name Then
        adt = adt + 1
        If adt = 1 Then
            arr = sh.Range("A1").CurrentRegion.Value
        Else
            arr = sh.Range("A1").CurrentRegion.Offset(1, 0).Value
        End If
        i = ws.Cells(Rows.Count, "A").End(3).Row + 1
        ws.Range("A" & i).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    End If
Next sh

With ws
    .Select
    .Cells.EntireColumn.AutoFit
    .Rows(1).Delete
End With

Application.ScreenUpdating = True

MsgBox adt & " ADET SAYFA BİRLEŞTİRİLMİŞTİR...."

End Sub


Function SayfaVar(syfAdi As String) As Boolean

On Error Resume Next
SayfaVar = Len(Sheets(syfAdi).Name) > 0

End Function

 

[bulentkars]

Muzaffer Ali Bey;
Necdet Bey;
Her iki dosyada işimi gördü. Elinize Emeğinize sağlık. Çok Teşekkür ederim.

 

[besen]

Merhaba.

Sub Tum_sayfaları_Birlestir()
   
    Dim sh As Worksheet
    Dim wsAna As Worksheet
    Dim son As Long, anason As Long
   
    Set wsAna = Sheets.Add(After:=ActiveSheet)    'Yeni Sayfa Oluştur.
    ActiveSheet.Name = "Tüm Sayfalar"

   
    For Each sh In Worksheets
        If Not sh.Name = "Tüm Sayfalar" Then
            anason = wsAna.Cells(Rows.Count, 1).End(xlUp).Row
            son = sh.Cells(Rows.Count, 1).End(xlUp).Row
            sh.Range("A1:XFD" & son).Copy wsAna.Range("A" & anason)
        End If
    Next
    Cells.EntireColumn.AutoFit
End Sub

Merhaba sayfaları birleştirirken almadığı satır var, sebebi ne olabilir acaba.
Teşekkür ederim.

 

[Muzaffer Ali]

Merhaba sayfaları birleştirirken almadığı satır var, sebebi ne olabilir acaba.
Teşekkür ederim.

Aşağıdaki kodu deneyin. yukarıdaki kodda +1 kısmını unutmuşum.

Sub Tum_sayfaları_Birlestir()
    
    Dim sh As Worksheet
    Dim wsAna As Worksheet
    Dim son As Long, anason As Long
    
    Set wsAna = Sheets("Tüm Sayfalar")
    For Each sh In Worksheets
        If Not sh.Name = "Tüm Sayfalar" Then
            anason = wsAna.Cells(Rows.Count, 1).End(xlUp).Row + 1
            son = sh.Cells(Rows.Count, 1).End(xlUp).Row
            sh.Range("A2:XFD" & son).Copy wsAna.Range("A" & anason)
        End If
    Next
    Cells.EntireColumn.AutoFit
End Sub

 

[besen]

Aşağıdaki kodu deneyin. yukarıdaki kodda +1 kısmını unutmuşum.

Sub Tum_sayfaları_Birlestir()
   
    Dim sh As Worksheet
    Dim wsAna As Worksheet
    Dim son As Long, anason As Long
   
    Set wsAna = Sheets("Tüm Sayfalar")
    For Each sh In Worksheets
        If Not sh.Name = "Tüm Sayfalar" Then
            anason = wsAna.Cells(Rows.Count, 1).End(xlUp).Row + 1
            son = sh.Cells(Rows.Count, 1).End(xlUp).Row
            sh.Range("A2:XFD" & son).Copy wsAna.Range("A" & anason)
        End If
    Next
    Cells.EntireColumn.AutoFit
End Sub

Başka değişikliklerde olmuş, kod çalışmıyor bu sefer.
Teşekkür ederim.

 

[besen]

Eski makroya +1 ekledim, çalıştı.


Sub Tum_sayfaları_Birlestir()

Dim sh As Worksheet
Dim wsAna As Worksheet
Dim son As Long, anason As Long

Set wsAna = Sheets.Add(After:=ActiveSheet) 'Yeni Sayfa Oluştur.
ActiveSheet.Name = "Tüm Sayfalar"


For Each sh In Worksheets
If Not sh.Name = "Tüm Sayfalar" Then
anason = wsAna.Cells(Rows.Count, 1).End(xlUp).Row + 1
son = sh.Cells(Rows.Count, 1).End(xlUp).Row
sh.Range("A1:XFD" & son).Copy wsAna.Range("A" & anason)
End If
Next
Cells.EntireColumn.AutoFit
End Sub