Soru Satırları Sütuna Çevirmek

RedStar

Altın Üye
Katılım
16 Temmuz 2006
Mesajlar
132
Excel Vers. ve Dili
Excel 2013 Dil Türkçe
İ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.
 

Ekli dosyalar

Korhan Ayhan

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
26,122
Excel Vers. ve Dili
OFFICE 2019 PRO TR
Deneyiniz.

Kod:
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

Altın Üye
Katılım
16 Temmuz 2006
Mesajlar
132
Excel Vers. ve Dili
Excel 2013 Dil Türkçe
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.
 

Ekli dosyalar

RedStar

Altın Üye
Katılım
16 Temmuz 2006
Mesajlar
132
Excel Vers. ve Dili
Excel 2013 Dil Türkçe
@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

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
26,122
Excel Vers. ve Dili
OFFICE 2019 PRO TR
Alternatif;

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

C++:
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
 
Üst