Excel Sayfaları Birleştirme

[yasinkaratas0359]

Merhabalar;

Excel Çalışma Sayfamda 2196 Sayfa Var Bunları Tek Bir Sayfada Birleştirmek İstiyorum. Nasıl Yapabilirim.

Saygılar
Yasin.

 

[Necdet]

Merhaba,
Makro ile yapabilirsiniz.
Aşağıdaki kodları bir modüle kopyalayıp çalıştırınız.
Kod TümSayfalar adında bir Sheet oluşturacak ve bu sayfada verileri birleştirecektir.
Kodu birden fazla çalıştırdığınızda bu sayfadaki verileri silip tekrar aktaracaktır.
Verileri hangi sayfadan aldığını A sütununa, , B sütunundan itibaren de verileri yazacak.

Sub SayfalariBirlestir()

Dim arr As Variant
Dim syf As Worksheet
Dim i   As Long
Dim j   As Integer
Dim drm As Boolean

Application.ScreenUpdating = False
On Error Resume Next

If Not Len(Sheets("TümSayfalar").Name) > 0 Then
    Sheets.Add before:=Sheets(1)
    ActiveSheet.Name = "TümSayfalar"
Else
    Sheets("TümSayfalar").Range("A1").CurrentRegion.ClearContents
End If

On Error GoTo 0

For Each syf In Worksheets
    If Not syf.Name = "TümSayfalar" Then
        j = j + 1
        If drm = False Then
            arr = syf.Range("A1").CurrentRegion.Value
            Sheets("TümSayfalar").Range("A1") = syf.Name
            Sheets("TümSayfalar").Range("B1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
            drm = True
        Else
            arr = syf.Range("A1").CurrentRegion.Offset(1).Value
            i = Sheets("TümSayfalar").Cells(Rows.Count, "B").End(3).Row + 1
            Sheets("TümSayfalar").Range("A" & i) = syf.Name
            Sheets("TümSayfalar").Range("B" & i).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
        End If
    End If
Next syf

Application.ScreenUpdating = True

MsgBox j & " ADET SAYFA TümSayfalara AKTARILMIŞTIR...."

End Sub