Excel Sayfalarını Boşluksuz Tek Sayfada Birleştirme

[orhanbaba]

İstendiğinde tüm excel sayfalarını ( Sayfa1-2-3-4-5-6-7............. ) tek sayfaya aktarabilmek. Örnekte ( sayfa adı hepsi ) satır boşluğu bırakmadan veri kaybı ( satır kaybı ) olmadan diğer sayfaları aktarabilmek.
Dikkat edilecek husus : Her sayfadaki bilgi olan satır sayısı sabit değil devamlı veri girişine devam edilecek.
Yeni sayfa açılabilecek ( Sayfa 20-21-22......... ) veya 50 sayfaya kadar açılacak gibi düşünelim. Çözüm üretmek için çaba sarfederseniz memnun olurum. Teşekkürler.
Örnek : http://59.tarim.gov.tr/deneme.xlsx

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Sub Birlestir()
    
    Dim i As Integer, son As Long, sat As Long
    
    Application.ScreenUpdating = False
    Sheets("Hepsi").Select
    Range("A2:H" & Rows.Count).ClearContents
    
    sat = 2
    For i = 1 To Worksheets.Count
        If Sheets(i).Name <> "Hepsi" Then
            son = Sheets(i).Cells(Rows.Count, "A").End(xlUp).Row
            Sheets(i).Range("A2").Resize(son, 8).Copy Cells(sat, "A")
            sat = Cells(Rows.Count, "A").End(xlUp).Row + 1
        End If
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

.

 

[askm]

Aşağıdaki kodlar işinizi görür sanırım.

Sub Askm_SayfalariBirlestir()
Dim i As Integer
On Error Resume Next
Sheets("Hepsi").Select
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A2")
For i = 2 To Sheets.Count
Sheets(i).Activate
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
Sheets("Hepsi").Select
MsgBox "İşleminiz tamamlanmıştır.", vbInformation, "ASERİN"
End Sub

 

[igultekin2000]

yazı karakteri

Aşağıdaki kodlar işinizi görür sanırım.

Sub Askm_SayfalariBirlestir()
Dim i As Integer
On Error Resume Next
Sheets("Hepsi").Select
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A2")
For i = 2 To Sheets.Count
Sheets(i).Activate
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
Sheets("Hepsi").Select
MsgBox "İşleminiz tamamlanmıştır.", vbInformation, "ASERİN"
End Sub

sayı olarak aktarma oluyor, ama harf karakteri olarak aktarmıyor. aktarsaydı çeşitli amaç için kullanılabilirdi.

 

[orhanbaba]

3 makroda işimi gördü.İlginiz ve emeğiniz için teşekkür ederim