Как создать функцию в VBA для возврата имен столбцов, соответствующих определенным критериям для каждой записи в наборе записей?

Question

У меня есть таблица с ответом на опрос. например., TableA:

CompanyID   Q1  Q2  Q3  Q4  Q5
CompanyA    I   I   N   N   I
CompanyB    I   I   I   I   I
CompanyC    I   I   N   N   N

Я использую MS-Access 2016. Я хочу создать функцию VBA, которая позволяла бы мне просматривать каждую запись в этой таблице и возвращать field.name, где ответом на вопрос является «N», разделенное запятой (,).

Пожалуйста, имейте в виду, что я ни в коем случае не эксперт, и не проходил никакого официального обучения Честно говоря, я изучаю большую часть своего VBA через этот форум. Спасибо всем, кто внес свой вклад в это сообщество.

Пока что я могу заставить VBA циклически проходить через каждую запись, но я сталкиваюсь с несколькими проблемами, см. Код ниже:

Public Function NResponses(strTable As String)

On Error GoTo Err_Handler

    Dim rs As DAO.Recordset      
    Dim fld As DAO.Field          
    Dim strOut As String            
    Dim lngLen As Long                     
    Dim strSeperator As String      

NResponses = Null

Set dbs = CurrentDb
Set rs = dbs.OpenRecordset("TableA")
strSeperator = ", "

Do While Not rs.EOF
    With rs
        For Each fld In .Fields
            If fld.Value = "N" Then
                strOut = strOut & fld.Name & strSeperator
            End If
        Next fld
        rs.MoveNext
    End With
Loop

rs.Close
Set rs = Nothing

'Clean Output - remove last comma from strOut
lngLen = Len(strOut) - Len(strSeperator)
    If lngLen > 0 Then
        MissingControls = Left(strOut, lngLen)
    End If

Exit_Handler:
    'Clean up
    Set rs = Nothing
    Exit Function

Err_Handler:
    MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "NResponses()"
    Resume Exit_Handler
End Function

Это возвращает следующее:

CompanyID   Q1  Q2  Q3  Q4  Q5  NResponses
CompanyA    I   I   N   N   I   Q1, Q3, Q4, Q5
CompanyB    I   I   I   I   I   Q1, Q3, Q4, Q5
CompanyC    N   I   I   N   N   Q1, Q3, Q4, Q5

Но мой желаемый конечный результат таков:

CompanyID   Q1  Q2  Q3  Q4  Q5  NResponses
CompanyA    I   I   N   N   I   Q3, Q4
CompanyB    I   I   I   I   I   
CompanyC    N   I   I   N   N   Q1, Q4, Q5

Ваша помощь с этим будет принята с благодарностью.

Answer 1

Рассмотрим решение SQL, использующее специальную функцию VBA, ConcatRelated Аллена Брауна, которая вызывается внутри запроса SQL.Скопируйте и сохраните функцию внутри стандартного модуля Access.

Сначала преобразуйте свою широкую таблицу в длинный формат с помощью запроса объединения.

SELECT Surveys.CompanyID, 'Q1' As Question, Surveys.Q1 As Response
FROM Surveys

UNION ALL
SELECT Surveys.CompanyID, 'Q2' As Question, Surveys.Q2 As Response
FROM Surveys

UNION ALL
SELECT Surveys.CompanyID, 'Q3' As Question, Surveys.Q3 As Response
FROM Surveys

UNION ALL
SELECT Surveys.CompanyID, 'Q4' As Question, Surveys.Q4 As Response
FROM Surveys

UNION ALL
SELECT Surveys.CompanyID, 'Q5' As Question, Surveys.Q5 As Response
FROM Surveys

Во-вторых, запустите условное агрегирование с ConcatRelated(), чтобы изменить длинную позицию обратно в широкую

SELECT s.CompanyID, 
       MAX(IIF(s.Question = 'Q1', s.Response)) As Q1,
       MAX(IIF(s.Question = 'Q2', s.Response)) As Q2,
       MAX(IIF(s.Question = 'Q3', s.Response)) As Q3,
       MAX(IIF(s.Question = 'Q4', s.Response)) As Q4,
       MAX(IIF(s.Question = 'Q5', s.Response)) As Q5,
       ConcatRelated("Question", "SurveysUnionQ", 
                     "CompanyID = '" & s.CompanyID & "' AND Response = 'N'") AS NResponses
FROM SurveysLongTableOrUnionQuery s
GROUP BY s.CompanyID

---

Динамическое решение

Если есть много вопросов, которые выше неосуществимы, создайте запрос динамического объединения с помощью зацикленного кода.В качестве альтернативы создайте таблицу и выполните INSERT...SELECT итеративно для каждого CompanyID и Вопрос , как показано ниже:

Public Sub BuildSurveyLongTable()
On Error GoTo Err_Handler
    Dim i As Long, cnt As Long
    Dim db As DAO.Database, tblDef As TableDef

    Set db = CurrentDb
    ' MAKE-TABLE QUERY (RUN ONLY ONCE, COMMENT OUT THEREAFTER)
'    db.Execute "SELECT TOP 1 Surveys.CompanyID, 'Q1' As Question, Surveys.Q1 As Response INTO SurveysLong FROM Surveys"
    db.Execute "DELETE FROM SurveysLong"

    Set tblDef = db.TableDefs("Surveys")

    For i = 2 To tblDef.Fields.Count - 1
        db.Execute "INSERT INTO SurveysLong (CompanyID, Question, Response)" _
                     & " SELECT Surveys.CompanyID, '" & tblDef.Fields(i).name & "' As Question," _
                     & "        Surveys.[" & tblDef.Fields(i).name & "] As Response" _
                     & " FROM Surveys"
    Next i

    MsgBox "Successfully completed!", vbInformation

Exit_Handler:
    Set tblDef = Nothing
    Set db = Nothing
    Exit Sub

Err_Handler:
    MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "RUN-TIME ERROR"
    Resume Exit_Handler
End Sub

Как указано выше, ниже приведен динамический запрос дляусловное агрегирование:

Public Sub BuildSurveyQuery()
On Error GoTo Err_Handler
    Dim i As Long
    Dim strSQL As String
    Dim db As DAO.Database, tblDef As TableDef, qdef As QueryDef

    strSQL = "SELECT s.CompanyID, "

    ' ITERATIVELY ADD CONDITIONAL AGGREGATION LINES
    Set db = CurrentDb
    Set tblDef = db.TableDefs("Surveys")

    For i = 2 To tblDef.Fields.Count - 1
        strSQL = strSQL & "MAX(IIF(s.Question = '" & tblDef.Fields(i).name & "', s.Response)) As [" & tblDef.Fields(i).name & "], "
    Next i

    ' REMOVE LAST COMMA
    strSQL = Left(strSQL, Len(strSQL) - 1)

    strSQL = strSQL & " ConcatRelated(""Question"", ""SurveysUnionQ""," _
                    & "              ""CompanyID = '"" & s.CompanyID & ""' AND Response = 'N'"") AS NResponses" _
                    & " FROM SurveysLong s" _
                    & " GROUP BY s.CompanyID"

    ' UPDATE SQL IN QUERY OBJECT AND RELEASE TO SAVE
    Set qdef = db.QueryDefs("SurveysWideConcatQ")
    qdef.SQL = strSQL
    Set qdef = Nothing

    MsgBox "Successfully completed!", vbInformation

Exit_Handler:
    Set tblDef = Nothing
    Set db = Nothing
    Exit Sub

Err_Handler:
    MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "RUN-TIME ERROR"
    Resume Exit_Handler
End Sub

---

Pivot Query

Фактически альтернативой условному агрегированию является эксклюзивный перекрестный запрос Access , который может вместить до 253вопросы (не более 255 столбцов), включая ConcatRelated.Обратите внимание: NResponses появится слева от столбцов вопроса, а не в конце справа).

TRANSFORM Max(s.Response) AS MaxResponse
SELECT s.CompanyID, 
       ConcatRelated("Question", "SurveysLong",    
                     "CompanyID = '" & s.CompanyID & "' AND Response = 'N'") AS NResponses
FROM SurveysLong s
GROUP BY s.CompanyID
PIVOT s.Question

Answer 2

привет, strOut это строка, это должен быть массив.

попробуйте что-то вроде этого (без проверки)

Dim strOut(10) ' array with 10 positions
Dim xAs Integer = 1 'var to array position
    Do While Not rs.EOF
        With rs
            For Each fld In .Fields
                If fld.Value = "N" Then
                    strOut(x) = strOut(x) & fld.Name & strSeperator
                    x=x+1
                End If

            Next fld
            rs.MoveNext
        End With
    Loop

Удачи