Sütunları Alt Alta Yazdırmak

[c a g a t a y]

Merhaba
Linkte verdiğim örnek excelimdeki gibi sütunlardaki sayıları (bkz Sheet1) alt alta toplamak istiyorum.
Ben Sheet2 de manuel olarak yaptim ama sütün ve satırlar cok fazla olacak, otomatik yaptırmam lazım

Yardımcı olacaklara şimdiden teşekkürler

Örnek Excelim

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Sutunlari_Alt_Alta_Listele()
    Dim S1 As Worksheet, S2 As Worksheet, Veri As Variant
    Dim Son_Satir As Long, Son_Sutun As Integer
    Dim X As Long, Y As Integer, Say As Long, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Sheet1")
    Set S2 = Sheets("Sheet2")
    
    S2.Range("A:A").Clear
    
    Son_Satir = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Son_Sutun = S1.Cells(1, S1.Columns.Count).End(1).Column
    
    Veri = S1.Range("B2:" & S1.Cells(Son_Satir, Son_Sutun).Address(0, 0)).Value
    
    ReDim Liste(1 To Son_Satir * Son_Sutun, 1 To 1)
    
    For Y = LBound(Veri, 2) To UBound(Veri, 2)
        For X = LBound(Veri, 1) To UBound(Veri, 1)
            If Veri(X, Y) <> "" Then
                Say = Say + 1
                Liste(Say, 1) = Veri(X, Y)
            End If
        Next
    Next

    S2.Range("A1").Resize(Say) = Liste

    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub