Query results horizontally for single line export to Excel

[TB11]

Hi.

I need to have the query render the results vertically, into a single row for exporting to Excel for mail merge. I've read that I need multiple crosstab queries to do this, but I am not really sure where/how to start.

Table: ID, Team, Color, Sport

Wish list results: TeamA, TeamAColor, TeamASport, TeamB, TeamBColor, TeamBSport, TeamC, TeamCColor, TeamC Sport, etc.

Or, do I need to export the query to Excel, then do formulas in each Excel column to copy value from column A across row 1?

Any thoughts?

Thanks.

 

[Minty]

You won't easily get that result layout into an Access query.
It's probably easier to Pivot/Transpose it in Excel, if you fancied a bit of a challenge you could probably automate the process completely from Access.

 

[Pat Hartman]

You can automate excel to fill in the columns or you can create a .csv file. I would probably use Write to export a .csv file which Excel can read or you can automate excel to open the .csv file and save as an .xlxs file.

Build the export using VBA. Use a DAO loop to read through the recordset, and if you are building a .cav, then concatenate each field separated with a comma and enclosed in quotes.

 

[TB11]

@Minty & @Pat Hartman Thanks. I appreciate the help.

 

[MajP]

So I built the table
tblTest tblTest

ID	Team	Color	Sport
1​	A	Red	Football
2​	B	Blue	Baseball
3​	C	Green	Hockey

And this code

Public Sub ExportCSV()
  Const TableName = "tblTest"
  Const DQ = """"
  Dim ExportFile As String
  Dim rs As DAO.Recordset
  Dim strOut As String
  Dim Team As String
  Dim Color As String
  Dim Sport As String
  Dim FS As Object
  Dim Stream As Object
 
  Set FS = CreateObject("Scripting.FileSystemObject")
  Set rs = CurrentDb.OpenRecordset(TableName)
  ExportFile = CurrentProject.Path & "\Export" & Format(Date, "yyyymmdd") & ".csv"
  If Dir(ExportFile) <> "" Then
    Kill ExportFile
  End If
  Debug.Print ExportFile
  Set Stream = FS.CreateTextFile(ExportFile, False, True)
 
  Do While Not rs.EOF
    Team = DQ & "Team_" & rs!Team & DQ
    Color = DQ & rs!Color & DQ
    Sport = DQ & rs!Sport & DQ
    If strOut = "" Then
      strOut = Team & "," & Color & "," & Sport
    Else
      strOut = strOut & "," & Team & "," & Color & "," & Sport
    End If
    rs.MoveNext
    
  Loop
  Stream.write strOut
  Stream.Close
End Sub

Which creates the correct CSV file with output like

"Team_A","Red","Football","Team_B","Blue","Baseball","Team_C","Green","Hockey"

However when I open in Excel it does not create individual cells just one cell that looks like

Team_A,"Red","Football","Team_B","Blue","Baseball","Team_C","Green","Hockey"

with the " removed from the first word.

Anyone tell me what needs to get added or modified?

 

[Sun_Force]

Anyone tell me what needs to get added or modified?

@MajP
We have a professor here who enjoys teaching us strange behavior of different apps.
Once he showed us how to do something like this. It may give you a hint.

It's exactly what he did. (he did it in #C. You may be able to do the same in vba too.)
1- Export the result as :

Team_A	Red	Football	Team_B	Blue	Baseball	Team_C	Green	Hockey

That is not space. Those are Tabs between each of them.
2- Save the result as yourfilename.dat
3- open the .dat file with Excel. (you will receive a message if you trust the file. just press OK)

Edit:
I just did it in notepad and it worked. I separated the words with tab. Saved it as .dat and opened it in Excel.

 

[MajP]

Thanks. I replaced the , with a tab and it worked. Not sure why the comma does not.

Public Sub ExportCSV()
  Const TableName = "tblTest"
  Const DQ = """"
  Dim ExportFile As String
  Dim rs As DAO.Recordset
  Dim strOut As String
  Dim Team As String
  Dim Color As String
  Dim Sport As String
  Dim FS As Object
  Dim Stream As Object
 
  Set FS = CreateObject("Scripting.FileSystemObject")
  Set rs = CurrentDb.OpenRecordset(TableName)
  ExportFile = CurrentProject.Path & "\Export" & Format(Date, "yyyymmdd") & ".csv"
  If Dir(ExportFile) <> "" Then
    Kill ExportFile
  End If
  Debug.Print ExportFile
  Set Stream = FS.CreateTextFile(ExportFile, False, True)
 
  Do While Not rs.EOF
    Team = DQ & "Team_" & rs!Team & DQ
    Color = DQ & rs!Color & DQ
    Sport = DQ & rs!Sport & DQ
    If strOut = "" Then
      'strOut = Team & "," & Color & "," & Sport
      strOut = Team & Chr(9) & Color & Chr(9) & Sport
    Else
      'strOut = strOut & "," & Team & "," & Color & "," & Sport
      strOut = strOut & Chr(9) & Team & Chr(9) & Color & Chr(9) & Sport
    End If
    rs.MoveNext
    
  Loop
  Stream.write strOut
  Stream.Close
End Sub

 

[arnelgp]

exporting to Excel for mail merge

for mailmerge, you can use your Current table structure?

 

[isladogs]

By default, at least in the UK, the separator for text files is a tab rather than a comma. (TSV rather than CSV in structure.)
When you double click the CSV file created, Excel opens and handles the layout automatically. In this case into a single cell.

However if you open the CSV file from Excel, you will get the text import wizard allowing you to edit how the file is handled

Alternatively export text files from Access as .txt so Excel automatically uses the import wizard

 

[MajP]

Thanks. As pointed out in the other thread by changing
Set Stream = FS.CreateTextFile(ExportFile, False, True)
to
Set Stream = FS.CreateTextFile(ExportFile, False, False)
Changes the file encoding from Unicode to ASCII

It works with this change.

 

[Auntiejack56]

Just love arrays for this sort of thing ...

Function ExportTeamsToExcelForMerge()
    Dim dbs As DAO.Database, strSQL As String
    Dim xlApp As Object, xlWB As Object, xlWS As Object
    Dim n As Long, i As Long, nCol As Long
    Dim arrTeams
On Error GoTo Catch_Error
    
    Set dbs = CurrentDb()
    
    Set xlApp = CreateObject("Excel.Application")
    Set xlWB = xlApp.Workbooks.Add
    Set xlWS = xlWB.Worksheets.Add
    xlWS.Name = "Teams Merge"
    
    strSQL = "SELECT t.Team, t.Color, t.Sport FROM tblTeams AS t;"
    arrTeams = dbs.OpenRecordset(strSQL, dbOpenSnapshot).GetRows(999)
    
    For n = 0 To UBound(arrTeams, 2)
        For i = 0 To UBound(arrTeams, 1)
            nCol = nCol + 1
            xlWS.cells(1, nCol) = arrTeams(i, n)
        Next
    Next
    xlApp.Visible = True
Proc_Exit:
    Set dbs = Nothing
    Set xlWS = Nothing
    Set xlWB = Nothing
    Set xlApp = Nothing
    Exit Function
Catch_Error:
    MsgBox Err.Description & vbCrLf & "Cannot export the teams to Excel.", vbInformation, "Export failed"
    Resume Proc_Exit
    Resume
  
End Function