Option Explicit

Sub ReFormat()

Dim i As Long, rw As Long
Dim Верно As String
Dim cnt As Integer, j As Integer
Dim wsn As String

Worksheets(1).Activate
Application.DisplayAlerts = False
Err.Clear
Do While Err.Number = 0
    On Error Resume Next
    Worksheets(2).Delete
Loop
With Worksheets(1).Sort
    With .SortFields
        .Clear
        .Add Key:=Cells(1, 3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    End With
    .SetRange Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 5))
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
    With .SortFields
        .Clear
        .Add Key:=Cells(1, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    End With
    .SetRange Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 5))
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
With Worksheets(1)
    Верно = ""
    cnt = 0
    For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
        On Error Resume Next
        wsn = Replace(Left(.Cells(i, 1).Value, 31), Chr(13), "", 1, -1, vbBinaryCompare)
        Err.Clear
        On Error Resume Next
        Worksheets(wsn).Activate
        If Err.Number <> 0 Then
            If Sheets.Count > 1 Then Cells(Cells(Rows.Count, 1).End(xlUp).Row, 13).Value = Верно
            Worksheets.Add after:=Worksheets(Sheets.Count)
            ActiveSheet.Name = wsn
            Range(Cells(1, 1), Cells(1, 2)).Value = Array("номер вопроса", "текст вопроса")
            For j = 1 To 10
            Cells(1, j + 2).Value = "вариант ответа " & j
            Next j
            Cells(1, 13).Value = "верный ответ"
        End If
        rw = Cells(Rows.Count, 1).End(xlUp).Row
        If Replace(Cells(rw, 2).Value, Chr(13), "", 1, -1, vbBinaryCompare) <> Replace(.Cells(i, 3).Value, Chr(13), "", 1, -1, vbBinaryCompare) Then
            rw = rw + 1
            If rw > 2 Then Cells(rw - 1, 13).Value = Верно
            .Cells(i, 3).Value = Replace(.Cells(i, 3).Value, Chr(13), "", 1, -1, vbBinaryCompare)
            Range(Cells(rw, 1), Cells(rw, 2)).Value = Array(.Cells(i, 2).Value, .Cells(i, 3).Value)
            Верно = ""
            cnt = 0
        End If
        .Cells(i, 4).Value = Replace(.Cells(i, 4).Value, Chr(13), "", 1, -1, vbBinaryCompare)
        Cells(rw, Cells(rw, Columns.Count).End(xlToLeft).Column + 1).Value = .Cells(i, 4).Value
        cnt = cnt + 1
        If .Cells(i, 5).Value = 1 Then Верно = IIf(Верно = "", cnt, Верно & "." & cnt)
    Next i
    Cells(rw, 13).Value = Верно
End With
ThisWorkbook.Save