MS-Access Dynamically Convert Variable Row Values into Variable Column Values Using VBA
Original code link: MS Access - Convert rows values into columns values
I have a follow up to a question where the answer didn't completely resolve, but got super close. It was asked at the original code link above. It's the single page on the net that actually addresses the issue of transposing multiple values in a one-to-many relationship set of columns to a single row for each related value in a dynamic manner specifically using VBA. Variations of this question have been asked about a dozen times on this site and literally none of the answers goes as far as Vlado did (the user that answered), which is what's necessary to resolve this problem.
I took what Vlado posted in that link, adjusted it for my needs, did some basic cleanup, worked through all the trouble-shooting and syntax problems (even removed a variable declared that wasn't used: f As Variant), and found that it works almost all the way. It generates the table with values for the first two columns correctly, iterates the correct number of variable count columns with headers correctly, but fails to populate the values within the cells for each of the related "many-values". So close!
In order to get it to that point, I have to comment-out db.Execute updateSql portion of the Transpose Function; 3rd to last row from the end. If I don't comment that out, it still generates the table, but it throws a Run-Time Error 3144 (Syntax error in UPDATE statement) and only creates the first row and all the correct columns with correct headers (but still no valid values inside the cells). Below is Vlado's code from the link above, but adjusted for my field name needs, and to set variables at the beginning of each of the two Functions defined. The second Function definitely works correctly.
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
Sample Table:
Sample Data:
So with the help of a friend I figured it out. It turns out I needed two Functions because the one-to-many relationships go both directions in my case. I explain below what needs to happen in comments for this to work. Essentially I went with the second comment under the question I posed (pre-defining field names in static tables because there is a limited number of fields that any person will need - it can't exceed 256 fields anyway, but it isn't always practical to use more than a dozen or so fields - this way allows for both and at the same time to simplify the code significantly).
This solution actually works - but it's dependent on having tables (or queries in my situation) labeled ConvergeSend and ConvergeReceive. Also, it's important to note that the instances where the Destination is single and the Source is plural, the table or query (ConvergeSend/ConvergeReceive) must have the Destination value as a column TO THE LEFT of the iterated Source columns. This is also true (but reverse naming convention) for the other table/query (the Source column must be TO THE LEFT of the iterated Destination columns).
' 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