Michael Kepley

Sub UpdateSurvey()

Dim counter As Integer
Dim row As Integer
Dim row_answer As Integer
Dim question As String
Dim answer As String
Dim answer_whole As String
Dim answer_find As Integer
Dim check As String
Dim start_here As Integer
Dim rfound As Range

counter = 1
question = Worksheets(1).Range("A1").Offset(0, counter + 1).Value

Do While question  ""

    sheetname = "Question " + CStr(counter)

    On Error Resume Next
    Worksheets(sheetname).Activate

    If Err.Number = 0 Then
        Application.DisplayAlerts = False
        Worksheets(sheetname).Delete
        Application.DisplayAlerts = True
    End If
    On Error GoTo 0
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = sheetname
    Worksheets(sheetname).Range("A1").Value = Worksheets(1).Range("A1").Offset(0, counter + 1).Value
    row = 1
    row_answer = 1
    check = Worksheets(1).Range("A1").Offset(row, 0).Value

    Do While check  ""

        answer_find = 1
        start_here = 1
        answer_whole = Worksheets(1).Range("A1").Offset(row, counter + 1).Value
        Do While answer_find  0
            answer_find = InStr(start_here, answer_whole, ";#")
            If answer_find = 0 Then
                answer = Mid(answer_whole, start_here)
            Else
                answer = Mid(answer_whole, start_here, answer_find - start_here)
            End If
            On Error Resume Next
            Worksheets(sheetname).Columns("B:B").Select
            Set rfound = Selection.Find(What:=answer, LookIn:=xlFormulas, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            If Not rfound Is Nothing Then
                rfound.Offset(0, 1).Value = rfound.Offset(0, 1).Value + 1
            Else
                Worksheets(sheetname).Range("A1").Offset(row_answer, 0).Value = row_answer
                Worksheets(sheetname).Range("A1").Offset(row_answer, 1).Value = "'" + answer
                Worksheets(sheetname).Range("A1").Offset(row_answer, 2).Value = 1
                row_answer = row_answer + 1
            End If
            On Error GoTo 0

            start_here = answer_find + 2
        Loop
        row = row + 1
        check = Worksheets(1).Range("A1").Offset(row, 0).Value

    Loop

    Worksheets(sheetname).Columns("B:C").Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortTextAsNumbers
    counter = counter + 1
    question = Worksheets(1).Range("A1").Offset(0, counter + 1).Value

Loop

End Sub

How to Change message

“You are not allowed to respond again to this survey. ”

Sharepoint survey list

Thanks
Surendra

My survey is having more than one multiple choice questions. Here you suggested to create a custom list for one question. So far more than one questions, should we extrapolate this approach? Should we create one custom list per question?

Regards,
Mark

Mark