Tek sayfada toplama

[kamil09]

Ya arkadaşlar birden çok sayfayı tek sayfada açılmasını istiyorum bunu nasıl bi kodla aynı sayfaya çağırabiliriz yardımlarınızı bekliyorum TEŞŞEKÜRLER

 

[xxcell]

Bunu yapabilmek için diğer sayfaları ilk sayfaya kopyalamanız gerekmekte. Bunu manuel yapmak yerine kod ile de yapabilirsiniz.

Kod yazarken (programcılıkta) en temel konu algoritmayı oluşturmaktır.

Bu kodun algoritması,

1. Birinci sayfadan sonrasından itibaren tüm sayfaların son hücrelerini bulup ilk hücreden itibaren kopyala
2. Birinci sayfanın son satırından itibaren yapıştır.

Not. Ufak bir de püf noktası var. Sayfa isimleri kullanıcı tarafından değiştirilebilir. Kullanıcı sayfa isimlerini değiştirdiyse Sayfa1, Sheet1 illaha ki Birinci sayfayı temsil etmez. Bu yüzden index numarası 1 olan sayfa 1.nci sayfadır.

Aşağıdaki kod diğer sayfalardaki verileri ilk sayfaya kopyalar.

Sub birlestir()

If Worksheets.Count > 1 Then

sonsatir = 1
n = 1
For sutun = 1 To Worksheets(n).Range("a1").SpecialCells(xlLastCell).Column
If Worksheets(n).Cells(65536, sutun).End(xlUp).Row > sonsatir Then sonsatir = Worksheets(n).Cells(65536, sutun).End(xlUp).Row
Next
aktarilacaksayfa_sonsatir = sonsatir

For n = 2 To Worksheets.Count
sonsatir = 1
sonsutun = 1
For sutun = 1 To Worksheets(n).Range("a1").SpecialCells(xlLastCell).Column
If Worksheets(n).Cells(65536, sutun).End(xlUp).Row > sonsatir Then sonsatir = Worksheets(n).Cells(65536, sutun).End(xlUp).Row
If Worksheets(n).Cells(65536, sutun).End(xlUp).Row > 1 Or Not IsEmpty(Worksheets(n).Cells(65536, sutun).End(xlUp)) Then sonsutun = Worksheets(n).Cells(65536, sutun).End(xlUp).Column
Next

If Not (sonsatir = 1 And sonsutun = 1 And IsEmpty(Worksheets(n).Cells(1, 1))) Then
Worksheets(n).Range("a1:" & Cells(sonsatir, sonsutun).Address).Copy


Worksheets(1).Range("a" & aktarilacaksayfa_sonsatir + 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
aktarilacaksayfa_sonsatir = aktarilacaksayfa_sonsatir + sonsatir

End If

Next
End If

End Sub

 

[baydeniro]

Sayın xxcell, paylaşım için çok teşekkürler.