如何在 VBA 到 return 列名称中为记录集中的每条记录创建与特定条件匹配的函数？
How to create a function in VBA to return column names matching a certain criteria for each record in a recordset?
我有一个 table，其中包含对调查的回复。例如。，
表 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 函数，让我可以遍历 table 和 return [=31] 中的每条记录=] 其中对问题的回答是 "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
这 return 如下：
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是字符串，必须是数组。
试试这样的东西（未经测试）
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
祝你好运
考虑使用特殊 VBA 函数的 SQL 解决方案，Allen Browne 的 ConcatRelated 在 SQL 查询中调用。将函数复制并保存在 Access 标准模块中。
首先，使用联合查询将宽格式 table 重塑为长格式。
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 迭代创建 table 和 运行 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
我有一个 table，其中包含对调查的回复。例如。， 表 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 函数，让我可以遍历 table 和 return [=31] 中的每条记录=] 其中对问题的回答是 "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
这 return 如下：
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是字符串，必须是数组。
试试这样的东西（未经测试）
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
祝你好运
考虑使用特殊 VBA 函数的 SQL 解决方案，Allen Browne 的 ConcatRelated 在 SQL 查询中调用。将函数复制并保存在 Access 标准模块中。
首先，使用联合查询将宽格式 table 重塑为长格式。
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 迭代创建 table 和 运行 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