MS-Access 使用 VBA 将变量行值动态转换为变量列值
MS-Access Dynamically Convert Variable Row Values into Variable Column Values Using VBA
原码link：MS Access - Convert rows values into columns values
我跟进了一个问题，答案没有完全解决，但非常接近。在上面的 原始代码 link 中被问到。它是网络上的单个页面，它实际上解决了将 one-to-many 列关系集中的多个值以动态方式 转置为每个相关值的单个行的问题 使用 VBA。这个问题的变体已经在这个网站上被问了十几次，字面上 none 的答案就 Vlado（回答的用户）所做的而言，这是解决这个问题所必需的。
我采用了 Vlado 在 link 中发布的内容，根据我的需要对其进行了调整，进行了一些基本清理，解决了所有 trouble-shooting 和语法问题（甚至删除了声明为“ t used: f As Variant), 发现一直都almost有效。它使用前两列的值正确生成 table，使用 headers 正确迭代变量计数列的正确数量，但无法在 内填充值 每个相关“many-values”的单元格。太近了！
为了做到这一点，我必须 comment-out db.Execute updateSql 转置函数的一部分；倒数第三行。如果我不注释掉它，它仍然会生成 table，但它会抛出 Run-Time 错误 3144（UPDATE 语句中的语法错误）并且只创建第一行和所有正确的列headers（但单元格内仍然没有有效值）。下面是来自上面 link 的 Vlado 代码，但根据我的字段名称需要进行了调整，并在定义的两个函数的每个函数的开头设置了变量。第二个函数绝对可以正常工作。
Public Function Transpose()
Dim DestinationCount As Integer, i As Integer
Dim sql As String, insSql As String, fieldsSql As String, updateSql As String, updateSql2 As String
Dim db As DAO.Database, rs As DAO.Recordset, grp As DAO.Recordset
Dim tempTable As String, myTable As String
Dim Var1 As String, Var2 As String, Var3 As String, Var4 As String
tempTable = "Transposed" 'Value for Table to be created with results
myTable = "ConvergeCombined" 'Value for Table or Query Source with Rows and Columns to Transpose
Var1 = "Source" 'Value for Main Rows
Var2 = "Thru" 'Value for Additional Rows
Var3 = "Destination" 'Value for Columns (Convert from Rows to Columns)
Var4 = "Dest" 'Value for Column Name Prefixes
DestinationCount = GetMaxDestination
Set db = CurrentDb()
If Not IsNull(DLookup("Name", "MSysObjects", "Name='" & tempTable & "'")) Then
DoCmd.DeleteObject acTable, tempTable
End If
fieldsSql = ""
sql = "CREATE TABLE " & tempTable & " (" & Var1 & " CHAR," & Var2 & " CHAR "
For i = 1 To DestinationCount
fieldsSql = fieldsSql & ", " & Var4 & "" & i & " INTEGER"
Next i
sql = sql & fieldsSql & ")"
db.Execute (sql)
insSql = "INSERT INTO " & tempTable & " (" & Var1 & ", " & Var2 & ") VALUES ("
Set grp = db.OpenRecordset("SELECT DISTINCT " & Var1 & ", " & Var2 & " FROM " & myTable & " GROUP BY " & Var1 & ", " & Var2 & "")
grp.MoveFirst
Do While Not grp.EOF
sql = "'" & grp(0) & "','" & grp(1) & "')"
db.Execute insSql & sql
Set rs = db.OpenRecordset("SELECT * FROM " & myTable & " WHERE " & Var1 & " = '" & grp(0) & "' AND " & Var2 & " = '" & grp(1) & "'")
updateSql = "UPDATE " & tempTable & " SET "
updateSql2 = ""
i = 0
rs.MoveFirst
Do While Not rs.EOF
i = i + 1
updateSql2 = updateSql2 & "" & Var3 & "" & i & " = " & rs(2) & ", " ' <------- MADE CHANGE FROM (3) to (2)
rs.MoveNext
Loop
updateSql = updateSql & Left(updateSql2, Len(updateSql2) - 1) & " WHERE " & Var1 & " = '" & grp(0) & "' AND " & Var2 & " = '" & grp(1) & "'"
db.Execute updateSql ' <-- This is the point of failure
grp.MoveNext
Loop
End Function
Public Function GetMaxDestination()
Dim rst As DAO.Recordset, strSQL As String
myTable = "ConvergeCombined" 'Value for Table or Query Source with Rows and Columns to Transpose
Var1 = "Source" 'Value for Main Rows
Var2 = "Thru" 'Value for Additional Rows
Var3 = "Destination" 'Value for Columns (Convert from Rows to Columns)
strSQL = "SELECT MAX(CountOfDestination) FROM (SELECT Count(" & Var3 & ") AS CountOfDestination FROM " & myTable & " GROUP BY " & Var1 & ", " & Var2 & ")"
Set rst = CurrentDb.OpenRecordset(strSQL)
GetMaxDestination = rst(0)
rst.Close
Set rst = Nothing
End Function
样本Table：
示例数据：
在该执行行之前添加一个 Debug.Print updateSql，将在 SQL 语句中看到不正确的语法。需要 trim 来自 updateSql2 字符串的尾随逗号。代码附加了一个逗号和 space 但只有 trims 1 个字符。从连接中删除 space 或 trim 2 个字符。
Left(updateSql2, Len(updateSql2) - 2)
updateSql2 的串联使用 Var3 而不是 Var4。
源字段是 ConvergeCombined 中的数字类型，这会触发 SELECT 语句中的 'type mismatch' 错误以打开记录集，因为撇号分隔符 Var1 & " = '" & grp(0) & "' - 将它们从两个 SQL 语句。
另外，Source 值被保存到 Transposed 中的文本字段，在 CREATE TABLE 操作中将其设为 INTEGER 而不是 CHAR。
所以在朋友的帮助下我弄明白了。事实证明我需要两个函数，因为 one-to-many 关系在我的例子中是双向的。我在下面解释了评论中需要发生什么才能使它起作用。本质上，我在我提出的问题下进行了第二条评论（pre-defining static tables 中的字段名称，因为任何人都需要的字段数量有限 - 无论如何不能超过 256 个字段, 但使用十几个左右的字段并不总是可行的 - 这种方式允许同时显着简化代码）。
此解决方案确实有效 - 但它依赖于将 tables（或在我的情况下的查询）标记为 ConvergeSend 和 ConvergeReceive。另外，需要注意的是，在 Destination 为单个而 Source 为复数的情况下，table 或查询 (ConvergeSend/ConvergeReceive) 必须将 Destination 值作为迭代源左侧的列列。对于其他 table/query（源列必须位于迭代目标列的左侧）也是如此（但相反的命名约定）。
' For this code to work, create a table named "TransposedSend" with 8 columns: Source, Destination1, Destination2,...Destination7; OR however many you need
' Save the table, Edit it, change all field values to Number and remove the 0 as Default Value at the bottom
' Not changing the field values to Number causes the Insert Into function to append trailing spaces for no apparent reason
Public Function TransposeSend()
Dim i As Integer
Dim rs As DAO.Recordset, grp As DAO.Recordset
CurrentDb.Execute "DELETE * FROM TransposedSend", dbFailOnError
CurrentDb.Execute "INSERT INTO TransposedSend (Source) SELECT DISTINCT Source FROM ConvergeSend GROUP BY Source", dbFailOnError
Set grp = CurrentDb.OpenRecordset("SELECT DISTINCT Source FROM ConvergeSend GROUP BY Source")
grp.MoveFirst
Do While Not grp.EOF
Set rs = CurrentDb.OpenRecordset("SELECT Source, Destination, [Destination App Name] FROM ConvergeSend WHERE Source = " & grp(0))
i = 0
rs.MoveFirst
Do While Not rs.EOF
i = i + 1
CurrentDb.Execute "UPDATE TransposedSend SET Destination" & i & " = '" & rs(1) & "', [Destination" & i & " App Name] = '" & rs(2) & "'" & " WHERE Source = " & grp(0)
rs.MoveNext
Loop
grp.MoveNext
Loop
End Function
' For this code to work, create a table named "TransposedReceive" with 8 columns: Destination, Source1, Source2,...Source7; OR however many you need
' Save the table, Edit it, change all field values to Number and remove the 0 as Default Value at the bottom
' Not changing the field values to Number causes the Insert Into function to append trailing spaces for no apparent reason
Public Function TransposeReceive()
Dim i As Integer
Dim rs As DAO.Recordset, grp As DAO.Recordset
CurrentDb.Execute "DELETE * FROM TransposedReceive", dbFailOnError
CurrentDb.Execute "INSERT INTO TransposedReceive (Destination) SELECT DISTINCT Destination FROM ConvergeReceive GROUP BY Destination", dbFailOnError
Set grp = CurrentDb.OpenRecordset("SELECT DISTINCT Destination FROM ConvergeReceive GROUP BY Destination")
grp.MoveFirst
Do While Not grp.EOF
Set rs = CurrentDb.OpenRecordset("SELECT Destination, Source, [Source App Name] FROM ConvergeReceive WHERE Destination = " & grp(0))
i = 0
rs.MoveFirst
Do While Not rs.EOF
i = i + 1
CurrentDb.Execute "UPDATE TransposedReceive SET Source" & i & " = '" & rs(1) & "', [Source" & i & " App Name] = '" & rs(2) & "'" & " WHERE Destination = " & grp(0)
rs.MoveNext
Loop
grp.MoveNext
Loop
End Function
原码link：MS Access - Convert rows values into columns values
我跟进了一个问题，答案没有完全解决，但非常接近。在上面的 原始代码 link 中被问到。它是网络上的单个页面，它实际上解决了将 one-to-many 列关系集中的多个值以动态方式 转置为每个相关值的单个行的问题 使用 VBA。这个问题的变体已经在这个网站上被问了十几次，字面上 none 的答案就 Vlado（回答的用户）所做的而言，这是解决这个问题所必需的。
我采用了 Vlado 在 link 中发布的内容，根据我的需要对其进行了调整，进行了一些基本清理，解决了所有 trouble-shooting 和语法问题（甚至删除了声明为“ t used: f As Variant), 发现一直都almost有效。它使用前两列的值正确生成 table，使用 headers 正确迭代变量计数列的正确数量，但无法在 内填充值 每个相关“many-values”的单元格。太近了！
为了做到这一点，我必须 comment-out db.Execute updateSql 转置函数的一部分；倒数第三行。如果我不注释掉它，它仍然会生成 table，但它会抛出 Run-Time 错误 3144（UPDATE 语句中的语法错误）并且只创建第一行和所有正确的列headers（但单元格内仍然没有有效值）。下面是来自上面 link 的 Vlado 代码，但根据我的字段名称需要进行了调整，并在定义的两个函数的每个函数的开头设置了变量。第二个函数绝对可以正常工作。
Public Function Transpose()
Dim DestinationCount As Integer, i As Integer
Dim sql As String, insSql As String, fieldsSql As String, updateSql As String, updateSql2 As String
Dim db As DAO.Database, rs As DAO.Recordset, grp As DAO.Recordset
Dim tempTable As String, myTable As String
Dim Var1 As String, Var2 As String, Var3 As String, Var4 As String
tempTable = "Transposed" 'Value for Table to be created with results
myTable = "ConvergeCombined" 'Value for Table or Query Source with Rows and Columns to Transpose
Var1 = "Source" 'Value for Main Rows
Var2 = "Thru" 'Value for Additional Rows
Var3 = "Destination" 'Value for Columns (Convert from Rows to Columns)
Var4 = "Dest" 'Value for Column Name Prefixes
DestinationCount = GetMaxDestination
Set db = CurrentDb()
If Not IsNull(DLookup("Name", "MSysObjects", "Name='" & tempTable & "'")) Then
DoCmd.DeleteObject acTable, tempTable
End If
fieldsSql = ""
sql = "CREATE TABLE " & tempTable & " (" & Var1 & " CHAR," & Var2 & " CHAR "
For i = 1 To DestinationCount
fieldsSql = fieldsSql & ", " & Var4 & "" & i & " INTEGER"
Next i
sql = sql & fieldsSql & ")"
db.Execute (sql)
insSql = "INSERT INTO " & tempTable & " (" & Var1 & ", " & Var2 & ") VALUES ("
Set grp = db.OpenRecordset("SELECT DISTINCT " & Var1 & ", " & Var2 & " FROM " & myTable & " GROUP BY " & Var1 & ", " & Var2 & "")
grp.MoveFirst
Do While Not grp.EOF
sql = "'" & grp(0) & "','" & grp(1) & "')"
db.Execute insSql & sql
Set rs = db.OpenRecordset("SELECT * FROM " & myTable & " WHERE " & Var1 & " = '" & grp(0) & "' AND " & Var2 & " = '" & grp(1) & "'")
updateSql = "UPDATE " & tempTable & " SET "
updateSql2 = ""
i = 0
rs.MoveFirst
Do While Not rs.EOF
i = i + 1
updateSql2 = updateSql2 & "" & Var3 & "" & i & " = " & rs(2) & ", " ' <------- MADE CHANGE FROM (3) to (2)
rs.MoveNext
Loop
updateSql = updateSql & Left(updateSql2, Len(updateSql2) - 1) & " WHERE " & Var1 & " = '" & grp(0) & "' AND " & Var2 & " = '" & grp(1) & "'"
db.Execute updateSql ' <-- This is the point of failure
grp.MoveNext
Loop
End Function
Public Function GetMaxDestination()
Dim rst As DAO.Recordset, strSQL As String
myTable = "ConvergeCombined" 'Value for Table or Query Source with Rows and Columns to Transpose
Var1 = "Source" 'Value for Main Rows
Var2 = "Thru" 'Value for Additional Rows
Var3 = "Destination" 'Value for Columns (Convert from Rows to Columns)
strSQL = "SELECT MAX(CountOfDestination) FROM (SELECT Count(" & Var3 & ") AS CountOfDestination FROM " & myTable & " GROUP BY " & Var1 & ", " & Var2 & ")"
Set rst = CurrentDb.OpenRecordset(strSQL)
GetMaxDestination = rst(0)
rst.Close
Set rst = Nothing
End Function
样本Table：
示例数据：
在该执行行之前添加一个 Debug.Print updateSql，将在 SQL 语句中看到不正确的语法。需要 trim 来自 updateSql2 字符串的尾随逗号。代码附加了一个逗号和 space 但只有 trims 1 个字符。从连接中删除 space 或 trim 2 个字符。
Left(updateSql2, Len(updateSql2) - 2)
updateSql2 的串联使用 Var3 而不是 Var4。
源字段是 ConvergeCombined 中的数字类型，这会触发 SELECT 语句中的 'type mismatch' 错误以打开记录集，因为撇号分隔符 Var1 & " = '" & grp(0) & "' - 将它们从两个 SQL 语句。
另外，Source 值被保存到 Transposed 中的文本字段，在 CREATE TABLE 操作中将其设为 INTEGER 而不是 CHAR。
所以在朋友的帮助下我弄明白了。事实证明我需要两个函数，因为 one-to-many 关系在我的例子中是双向的。我在下面解释了评论中需要发生什么才能使它起作用。本质上，我在我提出的问题下进行了第二条评论（pre-defining static tables 中的字段名称，因为任何人都需要的字段数量有限 - 无论如何不能超过 256 个字段, 但使用十几个左右的字段并不总是可行的 - 这种方式允许同时显着简化代码）。
此解决方案确实有效 - 但它依赖于将 tables（或在我的情况下的查询）标记为 ConvergeSend 和 ConvergeReceive。另外，需要注意的是，在 Destination 为单个而 Source 为复数的情况下，table 或查询 (ConvergeSend/ConvergeReceive) 必须将 Destination 值作为迭代源左侧的列列。对于其他 table/query（源列必须位于迭代目标列的左侧）也是如此（但相反的命名约定）。
' For this code to work, create a table named "TransposedSend" with 8 columns: Source, Destination1, Destination2,...Destination7; OR however many you need
' Save the table, Edit it, change all field values to Number and remove the 0 as Default Value at the bottom
' Not changing the field values to Number causes the Insert Into function to append trailing spaces for no apparent reason
Public Function TransposeSend()
Dim i As Integer
Dim rs As DAO.Recordset, grp As DAO.Recordset
CurrentDb.Execute "DELETE * FROM TransposedSend", dbFailOnError
CurrentDb.Execute "INSERT INTO TransposedSend (Source) SELECT DISTINCT Source FROM ConvergeSend GROUP BY Source", dbFailOnError
Set grp = CurrentDb.OpenRecordset("SELECT DISTINCT Source FROM ConvergeSend GROUP BY Source")
grp.MoveFirst
Do While Not grp.EOF
Set rs = CurrentDb.OpenRecordset("SELECT Source, Destination, [Destination App Name] FROM ConvergeSend WHERE Source = " & grp(0))
i = 0
rs.MoveFirst
Do While Not rs.EOF
i = i + 1
CurrentDb.Execute "UPDATE TransposedSend SET Destination" & i & " = '" & rs(1) & "', [Destination" & i & " App Name] = '" & rs(2) & "'" & " WHERE Source = " & grp(0)
rs.MoveNext
Loop
grp.MoveNext
Loop
End Function
' For this code to work, create a table named "TransposedReceive" with 8 columns: Destination, Source1, Source2,...Source7; OR however many you need
' Save the table, Edit it, change all field values to Number and remove the 0 as Default Value at the bottom
' Not changing the field values to Number causes the Insert Into function to append trailing spaces for no apparent reason
Public Function TransposeReceive()
Dim i As Integer
Dim rs As DAO.Recordset, grp As DAO.Recordset
CurrentDb.Execute "DELETE * FROM TransposedReceive", dbFailOnError
CurrentDb.Execute "INSERT INTO TransposedReceive (Destination) SELECT DISTINCT Destination FROM ConvergeReceive GROUP BY Destination", dbFailOnError
Set grp = CurrentDb.OpenRecordset("SELECT DISTINCT Destination FROM ConvergeReceive GROUP BY Destination")
grp.MoveFirst
Do While Not grp.EOF
Set rs = CurrentDb.OpenRecordset("SELECT Destination, Source, [Source App Name] FROM ConvergeReceive WHERE Destination = " & grp(0))
i = 0
rs.MoveFirst
Do While Not rs.EOF
i = i + 1
CurrentDb.Execute "UPDATE TransposedReceive SET Source" & i & " = '" & rs(1) & "', [Source" & i & " App Name] = '" & rs(2) & "'" & " WHERE Destination = " & grp(0)
rs.MoveNext
Loop
grp.MoveNext
Loop
End Function