Transpose sequence of cells (Hard)

[Manolocs]

Hello, I am really exhausted of trying to solve this problem.
There is this spreadsheet It is a kind of questionnaire that is in different cells and I need to "transpose" cell to columns, but there are many data that must be deleted and others concatenated with spaces.
Sometimes there are more than hundreds sheets run.
I even can not explain very well without give you the sample spreadsheet.
Please take a look and let me know if this is possible to do in Excel.
Thanks in advance for your help.

https://dl.dropboxusercontent.com/u/14313867/MrExcel.xlsm

 

[Ombir]

This spreadsheet has been created from Word Document. May be I can assist if you share that word document.

 

[Manolocs]

No this is a pdf, I used a freeware PDF Converter to copy to a excel spreadsheet. If I copy direct from the PDF it is a mess.

 

[Ombir]

Please share the PDF.

 

[Manolocs]

Here it is.... Ombir
https://dl.dropboxusercontent.com/u/14313867/Mr_Excel.pdf

 

[Ombir]

Manolocs,

Font.Bold property of correct Option is not True in File provided by you. So moving the correct option in Column K is not feasible. I can provide the code for rest of the scenarios.

Let me know if you're okay with this.

 

[Manolocs]

yes lets try.... thanks

 

[Ombir]

Which freeware software you used to convert your Pdf to Excel ??

 

[Manolocs]

Which freeware software you used to convert your Pdf to Excel ??

PDF converter Pro

 

[Ombir]

Manolocs,

Good news for you. Correct answer issue has also been solved. Here is the macro code:

Dim qs As Long, qe As Long
Dim ques As String
Dim Ws As Worksheet
Sub Manolocs()
Dim i As Long, j As Long, k As Long
Dim m As Long, n As Long
Dim ar(1 To 200) As Long
Dim Rng As Range, cell As Range
Dim ows  As Worksheet
Dim options(1 To 4) As String
Dim opt As Range

On Error Resume Next
If IsError(Worksheets("Output").Range("A1")) Then
    Worksheets.Add.Name = "Output"
    Set ows = Sheets("Output")
Else
    Set ows = Sheets("Output")
End If

ows.UsedRange.ClearContents
ows.Range("A1:H1") = Array("Nr.", "ID", "ID Nr.", "Question", "Opt1", "Opt2", "Opt3", "Opt4")
m = 2

For Each Ws In Worksheets
    If Ws.Name <> ows.Name Then
    With Ws
        lr = .Cells(Rows.Count, 1).End(xlUp).Row
        Set Rng = .Range("B1:B" & lr)
        i = 1
        For Each cell In Rng
            If cell.Value Like "#" Or cell.Value Like "##" Then
                ar(i) = cell.Row
                i = i + 1
            End If
        Next
        ar(i) = lr
        i = 0
        For j = 1 To lr
            q = .Cells(j, 2).Value
            If q Like "#" Or q Like "##" Then
              n = 2
              i = i + 1
              qs = j
              qe = ar(i + 1) - 1
                For k = qs To qe
                    Set opt = .Cells(k, 1)
                  If Len(opt.Value) <> 0 Then
                  flag = cans(opt)
                    If flag And opt.Value Like "[a-d] *" Then
                        options(1) = Mid(opt.Value, 3)
                    ElseIf opt.Value Like "[a-d] *" Then
                        options(n) = Mid(opt.Value, 3)
                        n = n + 1
                    End If
                  End If
                Next
                Call question
                With ows
                    .Cells(m, 1) = Ws.Cells(j, 2)
                    .Cells(m, 2) = "Id"
                    .Cells(m, 3) = Ws.Cells(j, 2).Offset(1, 0)
                    .Cells(m, 4) = ques
                    .Cells(m, 5).Resize(, 4) = options
                    m = m + 1
                End With
            End If
        Erase options
        ques = ""
        Next
    End With
    End If
    Erase ar
Next
End Sub
Function cans(optn As Range) As Boolean
cans = False
If optn.Characters(3, 1).Font.Bold And optn.Text <> "id" = True Then
        cans = True
End If
End Function
Sub question()
Do While qs <> qe
    ques = ques + Ws.Cells(qs, 3) + " "
    qs = qs + 1
Loop
End Sub

You can also download workbook for testing from below link.

MrExcel.xlsm - Send Files Online - TempSend.com

Regards,
Ombir