Multi-Choice Questionnaire Translation

[Phildaburn]

In the database I'm connected to, responses to questions where more than one answer in a list can be selected from a questionnaire. These are stored as a value of X. The position of the X in the answer field corresponds to the number of the response(s) the person has chosen. For example: "What types of items to you frequently purchase?" and the possible responses displayed are: 01 Cosmetics, 02 Nutritional supplements, 03 Dental Hygiene...etc. The person taking the questionnaire sees the list and can select as many of the items in the list as they wish. However, the answers are stored as follows:
X X
XXX
X
etc.

I need to pull into the results of a query the english translation of those X answers. For the list of X answers above, the query results should look like this:
Cosmetics, Dential Hygiene
Cosmetics, Nutritional supplements, Dental Hygiene
Dental Hygiene

Any help would be appreciated. Thanks in advance...
Phil...

 

[Kreszch68]

Hi Phil,

with the next function you can pull the numbers from the string with the X values. I don't know how your table with the possible answers is structured, so I assumed that you want the numbers as 01, 02 etc.

Anyhow, you pass the string with X's to the function, and the function returns the corresponding numbers of selected items. From there you can use these values to retrieve the items from the corresponding table.

Public Function SelectedItems(ByVal sSelected) As String
Dim iRunner As Integer
Dim iSelected As Integer
Dim sAnswers() As String
Dim sNumbers As String
iSelected = 0
For iRunner = 1 To Len(sSelected)
        'Test
        If Mid(sSelected, iRunner, 1) = "X" Then
            ReDim Preserve sAnswers(iSelected)
                sAnswers(iSelected) = Right("00" & iRunner, 2)
            iSelected = iSelected + 1
            End If
Next iRunner
'Create string with the item numbers
sNumbers = Join(sAnswers, ", ")
SelectedItems = sNumbers
End Function

For testing use

Public Sub test()
Dim sSelected As String 'The values X
Dim returnValues As String 'The numbers
sSelected = "X X  X   X X"
returnValues = SelectedItems(sSelected)
Debug.Print returnValues
End Sub

 

[Phildaburn]

Thank you Kreszch68,

I'll try to answer your questions so perhaps we can get a bit closer to what it is I'm after. The code you've supplied is great and does indeed return the numeric positions of the X locations within the string. I believe this is a great first step.

Let me say that within the questionnaire itself, there are a number of questions. The questions themselves are of a variety of question types: Y/N, Single response from a multitude of possible responses, multiple responses from a multitude of possible responses, and a string of text. It is only this multiple responses type of answer I'm having trouble with and your solution shows promise and fills me with hope.

All the other types of responses are contained in that single field - the same field that carries values like X XX X. Because those other values are the verbal, easy-to-understand responses, they don't need extra work. I can easily pull them into the query results. For the multi-responses questions, the possible answers are stored in another table.

This other table contains fields for Question Name (a question name must be unique), Response Sequence (a 3-digit number), and the verbal translation I'll call the Response.

Since your code already generates a 2-digit number, it is easily modified to produce a 3-digit number. Once that 3-digit number is produced, I believe it could be used, along with a variable that holds the Question Name, to pull the Response from the response table - perhaps with a SQL query? Then, rather than returning the number values of the X positions, I would like it to return the Response values that correspond to the X positions.

I hope that makes sense. Thank you again in advance for your continued assistance.

Regards...
Phil...

 

[Kreszch68]

Hi Phil,

Could you please run the next code and send me the result (you can paste it here or in a PM). This way I can recreate your tables and have a look at how to deal with this.
Paste all code into a new module and enter new values for tablename and filepath

Option Compare Database
Option Explicit
Public Sub CallBuildSQL()
Dim sTableName As String
Dim sPathTextFile As String
sTableName = "[B][COLOR=red]TypeTableNameHere[/COLOR][/B]"
sPathTextFile = "[B][COLOR=red]Path where to save textfile[/COLOR][/B]\" [COLOR=seagreen]'include the last "\", eg c:\documents\[/COLOR]
BuildCreateSQL sTableName, sPathTextFile
 
End Sub
Public Sub BuildCreateSQL(ByVal sTableName As String, _
                          ByVal sPathTextFile As String)
Dim db As Database
Dim tdf As TableDef
Dim fld As DAO.Field
Dim ndx As DAO.Index
Dim sSQL As String
Dim sFlds() As String
Dim iFld As Integer
Dim sInd As String
Dim fs, f
    Set db = CurrentDb
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.CreateTextFile(sPathTextFile & sTableName & ".txt")
    For Each tdf In db.TableDefs
    '    If Left(tdf.Name, 4) <> "Msys" Then 'switch to this line for all tables
        If tdf.Name = sTableName Then
            sSQL = "sSQL=""CREATE TABLE [" & tdf.Name & "] ("
            iFld = -1
            For Each fld In tdf.Fields
                iFld = iFld + 1
                ReDim Preserve sFlds(iFld)
                sFlds(iFld) = "[" & fld.Name & "] "
                Select Case fld.Type
                        Case dbText
                            sFlds(iFld) = sFlds(iFld) & "Text (" & fld.Size & ")"
                        Case dbLong
                                If (fld.Attributes And dbAutoIncrField) = 0& Then
                                    sFlds(iFld) = sFlds(iFld) & "Long"
                                Else
                                    sFlds(iFld) = sFlds(iFld) & "Counter"
                                End If
                        Case dbBoolean
                            sFlds(iFld) = sFlds(iFld) & "YesNo"
                        Case dbByte
                            sFlds(iFld) = sFlds(iFld) & "Byte"
                        Case dbInteger
                            sFlds(iFld) = sFlds(iFld) & "Integer"
                        Case dbCurrency
                            sFlds(iFld) = sFlds(iFld) & "Currency"
                        Case dbSingle
                            sFlds(iFld) = sFlds(iFld) & "Single"
                        Case dbDouble
                            sFlds(iFld) = sFlds(iFld) & "Double"
                        Case dbDate
                            sFlds(iFld) = sFlds(iFld) & "DateTime"
                        Case dbBinary
                            sFlds(iFld) = sFlds(iFld) & "Binary"
                        Case dbLongBinary
                            sFlds(iFld) = sFlds(iFld) & "OLE Object"
                        Case dbMemo
                                If (fld.Attributes And dbHyperlinkField) = 0& Then
                                    sFlds(iFld) = sFlds(iFld) & "Memo"
                                Else
                                    sFlds(iFld) = sFlds(iFld) & "Hyperlink"
                                End If
                        Case dbGUID
                            sFlds(iFld) = sFlds(iFld) & "GUID"
                End Select
            Next
            sSQL = sSQL & Join(sFlds, ", ") & " )""" & vbCrLf & "Currentdb.Execute sSQL"
            f.WriteLine vbCrLf & sSQL
            'Indexes
            For Each ndx In tdf.Indexes
                        If ndx.Unique Then
                            sSQL = "sSQL=""CREATE UNIQUE INDEX "
                        Else
                            sSQL = "sSQL=""CREATE INDEX "
                        End If
                sSQL = sSQL & "[" & ndx.Name & "] ON [" & tdf.Name & "] ("
                        iFld = -1
                        For Each fld In ndx.Fields
                            iFld = iFld + 1
                            ReDim Preserve sFlds(iFld)
                            sFlds(iFld) = "[" & fld.Name & "]"
                        Next fld
                sSQL = sSQL & Join(sFlds, ", ") & ") "
                sInd = ""
                        If ndx.Primary Then
                            sInd = " PRIMARY"
                        End If
                        If ndx.Required Then
                            sInd = sInd & " DISALLOW NULL"
                        End If
                        If ndx.IgnoreNulls Then
                            sInd = sInd & " IGNORE NULL"
                        End If
                        If Trim(sInd) <> vbNullString Then
                            sSQL = sSQL & " WITH" & sInd & " "
                        End If
                f.WriteLine vbCrLf & sSQL & """" & vbCrLf & "Currentdb.Execute sSQL"
            Next ndx
        End If
    Next
    f.Close
End Sub