SAYFALARI TEK SATIRDA BİRLEŞTİRME

[stier_22]

Arkadaşlar elimde indirim listesi var ve 12 ayrı shett'te ben bunları tek tek kopyala yapıştır yapmak yerine tüm sayfaları bir sayfa içinde birleştirmek istiyorum

Örnek dosyam aşağıda olup normalde 12 sayfa ben kısa kesip 5 sayfa olarak gönderiyorum bunları tek sayfada birleştirmek için yardımcı olur musunuz

 

[AdemCan]

Dosyanızda aşağıdaki adımları uygulayınız.

1. Birleştir isimli bir sayfa oluşturup herhangi bir sayfadan iki satırdan oluşan başlığınızı bu sayfaya aynı sütunlara yapıştırınız.
2. Birleştirme işlemi için aşağıdaki kodları kullanabilirsiniz.

Sub birlestir()
Application.ScreenUpdating = False
Dim s1 As Worksheet, sayfa As Worksheet
Dim son As Long, son2 As Long, x As Long

Set s1 = Sheets("Birleştir")
son = s1.Cells(Rows.Count, 3).End(3).Row

s1.Range("B4:M" & son + 1).Clear

For Each sayfa In Worksheets
    If sayfa.Name <> "Birleştir" Then
    son = s1.Cells(Rows.Count, 3).End(3).Row + 1
        son2 = sayfa.Cells(Rows.Count, 3).End(3).Row
        sayfa.Range("C4:M" & son2).Copy s1.Range("C" & son)
    End If
Next

son = s1.Cells(Rows.Count, 3).End(3).Row
For x = 4 To son
    s1.Cells(x, 2).Value = x - 3
Next x

Set s1 = Nothing: Set sayfa = Nothing
son = 0: son2 = 0: x = 0
Application.ScreenUpdating = True
End Sub

 

[stier_22]

Dosyanızda aşağıdaki adımları uygulayınız.

1. Birleştir isimli bir sayfa oluşturup herhangi bir sayfadan iki satırdan oluşan başlığınızı bu sayfaya aynı sütunlara yapıştırınız.
2. Birleştirme işlemi için aşağıdaki kodları kullanabilirsiniz.

Sub birlestir()
Application.ScreenUpdating = False
Dim s1 As Worksheet, sayfa As Worksheet
Dim son As Long, son2 As Long, x As Long

Set s1 = Sheets("Birleştir")
son = s1.Cells(Rows.Count, 3).End(3).Row

s1.Range("B4:M" & son + 1).Clear

For Each sayfa In Worksheets
    If sayfa.Name <> "Birleştir" Then
    son = s1.Cells(Rows.Count, 3).End(3).Row + 1
        son2 = sayfa.Cells(Rows.Count, 3).End(3).Row
        sayfa.Range("C4:M" & son2).Copy s1.Range("C" & son)
    End If
Next

son = s1.Cells(Rows.Count, 3).End(3).Row
For x = 4 To son
    s1.Cells(x, 2).Value = x - 3
Next x

Set s1 = Nothing: Set sayfa = Nothing
son = 0: son2 = 0: x = 0
Application.ScreenUpdating = True
End Sub

Merhaba hocam bunu örnek dosyama yaptığımda oldu fakat ana dosyamda denediğimde hata veriyor (RUNTİME ERROR 9 SUBSCRİPT OUT OF RANGE)

 

[stier_22]

Dosyanızda aşağıdaki adımları uygulayınız.

1. Birleştir isimli bir sayfa oluşturup herhangi bir sayfadan iki satırdan oluşan başlığınızı bu sayfaya aynı sütunlara yapıştırınız.
2. Birleştirme işlemi için aşağıdaki kodları kullanabilirsiniz.

Sub birlestir()
Application.ScreenUpdating = False
Dim s1 As Worksheet, sayfa As Worksheet
Dim son As Long, son2 As Long, x As Long

Set s1 = Sheets("Birleştir")
son = s1.Cells(Rows.Count, 3).End(3).Row

s1.Range("B4:M" & son + 1).Clear

For Each sayfa In Worksheets
    If sayfa.Name <> "Birleştir" Then
    son = s1.Cells(Rows.Count, 3).End(3).Row + 1
        son2 = sayfa.Cells(Rows.Count, 3).End(3).Row
        sayfa.Range("C4:M" & son2).Copy s1.Range("C" & son)
    End If
Next

son = s1.Cells(Rows.Count, 3).End(3).Row
For x = 4 To son
    s1.Cells(x, 2).Value = x - 3
Next x

Set s1 = Nothing: Set sayfa = Nothing
son = 0: son2 = 0: x = 0
Application.ScreenUpdating = True
End Sub

Tamam şimdi oldu ana dosyada birleştir adını vermeyi unuttum hocam çok teşekkürler.
Peki buna buton nasıl ekleyebilirim mesela birleştir butonu da olsa direkt ona tıklasam

 

[Korhan Ayhan]

İnceleyiniz.

https://www.excel.web.tr/threads/sayfada-buton-duegme-olusturmak-ve-makro-atamak-1-resimli-anlatim.59436/

https://www.excel.web.tr/threads/sayfada-buton-duegme-olusturmak-ve-makro-atamak-2-resimli-anlatim.136979/

 

[AdemCan]

Sayfaya herhangi bir şekil ekleyip;
1- Şekil üzerinde Sağ Tuş \ Makro Ata.. yı tıklayınız


2- Açılan pencerede makro isimleri sıralanır. Birleştir isimli makroyu seçip Tamam ile işlemi sonlandırınız.
Artık butona tıklama ile ilgili makro çalışır.

 

[stier_22]

Çok sağol...

 

[AdemCan]

Rica ederim.