Birden çok satırları tek sutün haline getirme

[seiko_006]

Arkadaşlar,

elimde 50 bine yakın satırdan ve 3 sütündan oluşan bir dosya var.

1. sütünda kişi, ikinci sutunda soru, üçündü sutunda cevaplar var. her kişi farklı sayıda cevap vermiş. biri 2 soruya bir 5 soruya cevap vermiş.

benim yapmak istediğim,

birinci sütünda x kişinin verdiği cevapları (bazı cevaplar boş) boşluklarda dahil olmak üzere tek satırda x cevap1 cevap2 olarak sıralamak.

Örnek dosya ektedir. Lütfen yardımcı olursanız çok sevinirim.

 

[unreal_avci]

dosyaniz ekte.

 

[seiko_006]

acaba makro şeklinde olan var mı?

 

[Muhammet Okumuş]

Merhaba,

Sub Ayır()
Application.ScreenUpdating = False
Range("G2:GG100") = ""
son = Cells(Rows.Count, "A").End(3).Row
For i = 2 To son
adet = WorksheetFunction.CountIf(Range("G:G"), Cells(i, 1))
If adet = 0 Then Cells(Cells(Rows.Count, "G").End(3).Row + 1, "G") = Cells(i, 1).Value
kac = WorksheetFunction.Match(Cells(i, 1), Range("G:G"), 0)
süt = WorksheetFunction.CountA(Range(Cells(kac, 8), Cells(kac, 80))) + 8
Cells(kac, süt) = Cells(i, 3).Value
Next
End Sub

Kodu deneyiniz.

 

[Necdet]

Merhaba,

Bir deneme de benden olsun.

Sub Duzenle()
    
    Dim sh1 As Worksheet, _
        sh2 As Worksheet, _
        i   As Long, _
        j   As Long, _
        Son As Long, _
        Adt As Integer
    
    Application.ScreenUpdating = False
    
    Set sh1 = Sheets("Sayfa1")
    Set sh2 = Sheets("Sayfa2")
    
    sh2.Cells.ClearContents
    sh2.Range("A1") = "Kişi"
    sh2.Range("B1") = "YANITLAR"
    
    Son = sh1.Cells(Rows.Count, "A").End(3).Row
    
    i = 2
    j = 2
    
    Do
        Adt = Application.WorksheetFunction.CountIf(Range("A2:A" & Son), Cells(i, "A"))
        sh2.Cells(j, "A") = sh1.Cells(i, "A")
        sh1.Range("C" & i & ":C" & i + Adt - 1).Copy
        sh2.Cells(j, "B").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        j = j + 1
        i = i + Adt
    Loop While i < Son
    
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
    
    MsgBox "Düzenleme Bitmiştir....", vbInformation, "excel.web.tr"
    
End Sub