vba - 如何在 VBA 中创建一个函数以返回与记录集中每条记录的特定条件匹配的列名？

Question

我有一个表格，其中包含对调查的回复。例如。，表A:

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

考虑使用特殊 VBA 函数的 SQL 解决方案，Allen Browne 的 ConcatRelated在 SQL 查询中调用。将函数复制并保存在 Access 标准模块中。

首先，使用联合查询将宽表 reshape 为长格式。

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

---

动态解决方案

如果上面有很多题不可行，通过循环代码构建一个动态联合查询。或者，创建一个表并按每个 CompanyID 和 Question 迭代运行 INSERT...SELECT，如下所示:

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

---

透视查询

事实上，条件聚合的替代方法是 Access 独有的 crosstab query最多可容纳 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