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 500) As Long
Dim Rng As Range, cell As Range
Dim ows As Worksheet
Dim options(1 To 4) As String, tail As String
Dim opt As Range, flag As Boolean, bid As Boolean
Application.ScreenUpdating = False
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 "##" Or cell.Value Like "###" Then
bid = id(cell)
If bid Then
ar(i) = cell.Row
i = i + 1
End If
End If
Next
ar(i) = lr
i = 0
For j = 1 To lr
q = .Cells(j, 2).Value
If q Like "#" Or q Like "##" Or q Like "###" Then
bid = id(.Cells(j, 2))
If bid 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)
tail = opt.Offset(1, 1).Value
If flag And opt.Value Like "[a-d] *" Then
If tail <> .Cells(j, 2).Value + 1 Then
options(1) = Mid(opt.Value, 3) + " " + tail
Else
options(1) = Mid(opt.Value, 3)
End If
ElseIf opt.Value Like "[a-d] *" Then
If tail <> .Cells(j, 2).Value + 1 Then
options(n) = Mid(opt.Value, 3) + " " + tail
Else
options(n) = Mid(opt.Value, 3)
End If
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
End If
Erase options
ques = ""
Next
End With
End If
Erase ar
Next
Application.ScreenUpdating = True
End Sub
Function cans(optn As Range) As Boolean
cans = False
If optn.Characters(3, 1).Font.Bold And optn.Text <> "id" 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
Function id(qno As Range) As Boolean
id = False
If qno.Characters(1, 1).Font.Bold Then
id = True
End If
End Function
