Soru ve şıkları ayırma

[askm]

Kolay gelsin. Sayfa1 de sorular ve 4 şık aynı hücrede olmak üzere sorular mevcut. Sorular ile şıkları ayrı sütunlara almak istiyorum. A sütunlara soru B den itibaren B C D E şıklar. Bu şekilde vba yazabilir miyiz?

 

[vardar07]

Normalde şıklar sorunun altındamı. A1=soru, A2=şık1, A3=şık 2 gibimi? . Dosya olsa daha iyi olurdu.

 

[askm]

Bazı sorular dediğiniz gibi bazı sorular tek hücre içinde soru ve ışık şeklinde Benim istediğim tek Hücre içindeki ni börmek

 

[askm]

Şimdi cepten yazıyorum. Örnek yarın yükleyebilirim

 

[askm]

Örnek dosya ektedir. Sonuç sayfasındaki şekilde yapma imkanı olur mu?
İlgilenenlere şimdiden teşekkürler.

 

[askm]

Aşağıdaki kodlar ile yaptım. Yalnız bir sorum kaldı. Bazı sorular 2 satır oluyor. Bunları nasıl birleştirebiliriz. (C sütununa gelen A şıkkına göre (doluluk boşluk durumuna göre) A sütununa sıra numarası veriyorum. )

Sub Soru_Cek()
Dim sonsatir As Integer
Dim sonsutun As Integer
Dim s1, s2 As Worksheet
Set s1 = Worksheets("Sayfa1")
Set s2 = Worksheets("Sonuç")

sonsatir = s1.Range("A1048576").End(xlUp).Row
'sonsatir2 = s2.Cells(65536, "B").End(xlUp).Row

For i = 1 To sonsatir

    For s = 1 To 5
        If IsNumeric(Left(s1.Cells(i, s), 1)) = True Then
            s2.Range("B65536").End(3)(2, 1) = s1.Cells(i, s)
        End If
        If Left(s1.Cells(i, s), 2) = "A)" Then
            s2.Range("B65536").End(3)(1, 2) = s1.Cells(i, s)
           
        End If
        If Left(s1.Cells(i, s), 2) = "B)" Then
            s2.Range("B65536").End(3)(1, 3) = s1.Cells(i, s)
        End If
        If Left(s1.Cells(i, s), 2) = "C)" Then
            s2.Range("B65536").End(3)(1, 4) = s1.Cells(i, s).Value
        End If
        If Left(s1.Cells(i, s), 2) = "D)" Then
            s2.Range("B65536").End(3)(1, 5) = s1.Cells(i, s).Value 's2.Cells(sonsatir2 + 1, 5).Value = s1.Cells(i, s).Value
        End If
     Next s
Next i
End Sub