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

Posted 2023-05-07

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

【英文标题】：How to create a function in VBA to return column names matching a certain criteria for each record in a recordset?

【发布时间】：2019-05-21 13:38:09

【问题描述】：

我有一个表格，其中包含对调查的回复。例如。， 表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

我们将不胜感激您的帮助。

【问题讨论】：

您遍历整个表格，但您从未重置strOut。所以它只是不断地积累价值。如果您想在查询中使用该函数，正如您想要的结果所建议的那样，这种方法根本不起作用。您需要使用完整的 VBA 或完整的查询。

@Andre - 这是有道理的，因为我从未重置 strOut 将是它累积值的原因。我尝试了几种方法来进行更改，但仍然无法获得所需的结果。既然你说这行不通 - 关于我应该如何通过完整的 VBA 或查询来解决这个问题的任何更多指导？

【参考方案1】：

考虑一个使用特殊 VBA 函数的 SQL 解决方案，Allen Browne 的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() 运行条件聚合以将 long 重新整形为 Wide

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

【讨论】：

这看起来是一个非常有趣的解决方案，但正如您所提到的 - 大约有 200 个问题和数千家公司。如果我愿意听从您的建议和“或者，创建一个表并按每个 companyID 和问题在循环中迭代地运行“插入...选择”...我会怎么做。不太明白你的意思. 资源链接会有所帮助。

查看使用子例程进行更新以创建表并迭代地插入行并更新查询的 SQL，以针对最多 200 个问题进行条件聚合。我什至添加了一个交叉表查询。

非常感谢您花时间提供这些示例。我想我了解您要传达的内容，并且可能需要对动态查询进行一些编辑，因为我的实际表中的字段名称不是连续的 - 实际上没有特定的顺序。我会在处理您的示例时提供更新。

查看 update now 迭代表列以构建临时表和条件聚合查询（再一次，后一个查询可以替换为交叉表查询）。

太棒了！很高兴它奏效了。考虑在数据透视 (SELECT * INTO final_results FROM pivot_query) 完成后创建一个表，并将此表用于后续分析/报告。仅根据需要运行枢轴。

【参考方案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

祝你好运

【讨论】：

感谢您对此的意见，但我无法弄清楚如何使其工作。 @Parfait 能够将我带到我需要的地方，只是想对您的意见表示感谢。