Soru Satırları Sütuna Çevirmek

[RedStar]

İyi geceler benim çalışma sayfasında a,b ve c sütununda veriler mevcut ben satırlardaki verileri örnekte belirttiğim şekilde sütünların altında toplamak istiyorum örnek dosyam ektedir. İlgilenenlere teşekkür ederim.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Listele()
    Dim X As Long, Son As Long, Satir As Long
    
    Son = Cells(Rows.Count, 1).End(3).Row
    
    Range("G2:L" & Rows.Count).Clear
    Satir = 2
    
    For X = 2 To Son Step 4
        Range("G" & Satir & ":I" & Satir).Value = Range("A" & X & ":C" & X).Value
        Range("J" & Satir & ":L" & Satir).Value = Application.Transpose(Range("A" & X + 1 & ":A" & X + 3))
        Satir = Satir + 1
    Next
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[RedStar]

@Korhan Ayhan üstadım çok teşekkür ederim elinize kolunuza sağlık.

 

[RedStar]

Konu ile ilgili olarak satır sayısı sabit iken değişkenlik göstermeye başladı hali ile dosyada güncelleme gerekiyor yardımcı olacak üstadlara çok teşekkür ederim.

 

[Ziynettin]

"Test" referans olarak hazırlanmıştır.

 

[RedStar]

@Ziynettin üstad çok teşekkür ederim mükemmel çalışıyor. İlerleyen zamanda referans olarak kullanılan Test kelimesi değiştiğinde mesela ADANA yada ADIYAMAN olduğunda kodda nereleri değiştirmem lazım ikide bir sizi rahatsız etmeyin.

 

[Korhan Ayhan]

Alternatif;

Kod sarı renge göre işlem yapar.

Option Explicit

Sub Listele()
    Dim X As Long, Y As Long, Son As Long, Satir As Long, Sutun As Byte, Son_Sutun As Byte
    
    Son = Cells(Rows.Count, 1).End(3).Row
    
    Range("G:Z").Clear
    Satir = 2
    
    For X = 2 To Son
        If Cells(X, 1).Interior.ColorIndex = 6 Then
            Range("G" & Satir & ":I" & Satir).Value = Range("A" & X & ":C" & X).Value
            For Y = X + 1 To 100
                If Cells(Y, 1).Interior.ColorIndex = 6 Or Y > Son Then
                    Range("J" & Satir).Resize(1, Sutun).Value = Application.Transpose(Range("A" & X + 1 & ":A" & Y - 1))
                    X = Y - 1
                    Exit For
                Else
                    Sutun = Sutun + 1
                End If
            Next
            If Sutun > Son_Sutun Then Son_Sutun = Sutun
            Sutun = 0
            Satir = Satir + 1
        End If
    Next
    
    With Range("G1:I1")
        .Value = Array("FİRMA", "SINIF", "ADET")
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    
    With Range("J1").Resize(1, Son_Sutun)
        .Value = "VERİ"
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[RedStar]

Sayın @Korhan Ayhan çok teşekkür ederim.