Soruları sütundan satıra çevirme

[seiko_006]

Arkadaşlar,

Elimde 210000 fazla sütundan oluşan bir veri var. Bu verilerde 61 soruya cevap veren kullanıcılar var. sütün 1 de ID, sütun 2 de adı, sütun 3 de soyadı, sütün 4 de soru, sütün 5 de cevabı bulunuyor ve bunlar aşağı doğru sıralanarak gidiyor. Benim yapmak istediğim;

Tek bir kişi için; tek satıra ıd, adı, soyadı, soru1, cevap1, soru2,cevap 2 olarak tek satırda sıralamak,
ikinci kişide aynı şekilde altsatırda tek bir şekilde sıralamak,

Buna ilişkin excel dosyası ektedir.

Yardımcı olursanız çok sevinirim. Buna çok ihtiyacım var.

 

[seiko_006]

Satırları sutana alma

Arkadaşlar,

Elimde 210000 fazla sütundan oluşan bir veri var. Bu verilerde 61 soruya cevap veren kullanıcılar var. sütün 1 de ID, sütun 2 de adı, sütun 3 de soyadı, sütün 4 de soru, sütün 5 de cevabı bulunuyor ve bunlar aşağı doğru sıralanarak gidiyor. Benim yapmak istediğim;

Tek bir kişi için; tek satıra ıd, adı, soyadı, soru1, cevap1, soru2,cevap 2 olarak tek satırda sıralamak,
ikinci kişide aynı şekilde altsatırda tek bir şekilde sıralamak,

Buna ilişkin excel dosyası ektedir.

Yardımcı olursanız çok sevinirim. Buna çok ihtiyacım var.

 

[Necdet]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp dener misiniz?

Verileri Sayfa1 den okur Sayfa2 de düzenler.

Sub Yatay()
    
    Dim s1  As Worksheet, _
        s2  As Worksheet, _
        i   As Long, _
        j   As Long, _
        ID  As String, _
        Kol As Integer
    
    Application.ScreenUpdating = False
    
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    s2.Cells.ClearContents
    s1.Range("A1:C1").Copy s2.Range("A1")
    j = 1
    
    For i = 2 To s1.Cells(Rows.Count, "A").End(3).Row
    
        If Not ID = s1.Cells(i, "A") Then
            ID = s1.Cells(i, "A")
            j = j + 1
            Kol = 2
            s1.Range("A" & i & ":C" & i).Copy s2.Cells(j, "A")
        End If
        
        Kol = Kol + 2
        s1.Range("D" & i & ":E" & i).Copy s2.Cells(j, Kol)
        
    Next i
    
    Application.ScreenUpdating = True
    
    MsgBox "SAYFA2 YE LİSTELENMİŞTİR...", vbInformation, "N. YEŞERTENER --> Excel.Web.Tr"
    
End Sub

 

[Necdet]

Neden aynı soru için iki ayrı konu açıyorsunuz.

 

[omerceri]

Boşa gitmesin o kadar uğraşmıştım. Necdet Yeşertener cevaplamış.
Sayfa3'de İlk satıra Başlıklarınızı yazın ID,ADI,SOYADI

Sub a()
 Sheets("Sayfa3").Range("A2:DU10000").ClearContents
Say = [Sayfa1].[A10000].End(3).Row
For i = 2 To Say
If Sheets("Sayfa1").Range("A" & i).Value <> Sheets("Sayfa1").Range("A" & i - 1).Value Then
Say1 = [Sayfa3].[A10000].End(3).Row + 1
Sheets("Sayfa3").Cells(Say1, 1).Value = Sheets("Sayfa1").Range("A" & i)
Sheets("Sayfa3").Cells(Say1, 2).Value = Sheets("Sayfa1").Range("B" & i)
Sheets("Sayfa3").Cells(Say1, 3).Value = Sheets("Sayfa1").Range("C" & i)
Sheets("Sayfa3").Cells(Say1, 4).Value = Sheets("Sayfa1").Range("D" & i)
Sheets("Sayfa3").Cells(Say1, 5).Value = Sheets("Sayfa1").Range("E" & i)
Else
Say3 = Sheets("Sayfa3").Range("IU" & Say1).End(1).Column + 1
Sheets("Sayfa3").Cells(Say1, Say3).Value = Sheets("Sayfa1").Range("D" & i)
Sheets("Sayfa3").Cells(Say1, Say3 + 1).Value = Sheets("Sayfa1").Range("E" & i)
End If
Next i
End Sub

 

[seiko_006]

Katkılarınızdan dolayı teşekkür ederim. Necdet beyin gönderdiği işimi halleti.