Exporting from Access to Excel 56 times, help!

[scubadiver007]

Thanks to those who helped me with making some progress on this.

I can now export a set of data into the cell I want on the sheet using this code:

http://www.btabdevelopment.com/ts/tq2xlspecwspath

In the on-click event I have

=SendTQ2XLWbSheet("Query6","Reconciliation","O:\Medical\Enhanced Services\RECONCILIATIONS\Reconcilliations 2010-2011\Practice reconciliation\MASTER copy v4.xls")


The set of data has rows for 56 different codes and I need to send each of these data subsets to a different spreadsheet?

What is the best way to do this?

If I can't do it I can go back to importing all the data into a master sheet and then using VBA to create the separate files. That isn't a problem.

 

[boblarson]

You can do this but it will take creating your own function to go with the one you got from my website and we will need to modify my function so that it saves the workbook and closes it so you can iterate through.

The first part is changing the call to the VBA window for the On Click event instead of having it in the properties dialog, so you can iterate through and pull only the data that is required for your particular code. So, remove that function call from the form's properties dialog (for that click event) and then put the code in the VBA Window (see here for where to put it).

So, you would do something like this:

Dim rst As DAO.Recordset
 
Set rst = CurrentDb.OpenRecordset("Select [B][COLOR=red]YourCodeFieldNameHere[/COLOR][/B] From Query6")
 
Do Until rst.EOF
SendTQ2XLWbSheet "[COLOR=red]SELECT * FROM Query6 WHERE [B]YourCodeFieldNameHere[/B]= " & rst(0)[/COLOR] , "Reconciliation" [COLOR=red][B]& rst(0)[/B][/COLOR] , "O:\Me dical\Enhanced Services\RECONCILIATIONS\Reconcilliations 2010-2011\Practice reconciliation\MASTER copy v4.xls"
   rst.MoveNext
Loop
 
[COLOR=red]ApXL.Quit[/COLOR]
[COLOR=red]Set ApXL = Nothing[/COLOR]

And then you need to modify my function to remove this:

Dim ApXL As Object

and put it in the General Declarations section of the module that the SendTQ2XLWbSheet is in but change it to

Public ApXL As Object

And then modify the SendTQ2XLWbSheet to be like this:

[SIZE=2]Public Function SendTQ2XLWbSheet(strTQName As String, strSheetName As String, strFilePath As String)[/SIZE]
[SIZE=2]' strTQName is the name of the table or query you want to send to Excel[/SIZE]
[SIZE=2]' strSheetName is the name of the sheet you want to send it to[/SIZE]
 
[SIZE=2]' strFilePath is the name and path of the file you want to send this data into.[/SIZE]
 
 
[SIZE=2]  Dim rst As DAO.Recordset[/SIZE]
[SIZE=2]  Dim xlWBk As Object[/SIZE]
[SIZE=2]  Dim xlWSh As Object[/SIZE]
[SIZE=2]  Dim fld As DAO.Field[/SIZE]
[SIZE=2]  Dim strPath As String[/SIZE]
[SIZE=2]  Const xlCenter As Long = -4108[/SIZE]
[SIZE=2]  Const xlBottom As Long = -4107[/SIZE]
[SIZE=2]  On Error GoTo err_handler[/SIZE]
 
 
 
[SIZE=2]  strPath = strFilePath[/SIZE]
 
 
 
[SIZE=2]  Set rst = CurrentDb.OpenRecordset(strTQName)[/SIZE]
 
 
 
[SIZE=2][COLOR=red][B][SIZE=2]If ApXL Is Nothing Then[/SIZE][/B][/COLOR]
[SIZE=2][COLOR=red][B]    Set ApXL = CreateObject("Excel.Application")[/B][/COLOR][/SIZE]
[COLOR=red][B][SIZE=2] End If[/SIZE][/B][/COLOR]
 
[/SIZE]
 
 
[SIZE=2]  Set xlWBk = ApXL.Workbooks.Open(strPath)[/SIZE]
 
 
[SIZE=2]  ApXL.Visible = True[/SIZE]
 
 
[SIZE=2]  Set xlWSh = xlWBk.Worksheets(strSheetName)[/SIZE]
 
 
[SIZE=2]  xlWSh.Range("A1").Select[/SIZE]
 
 
[SIZE=2]  For Each fld In rst.Fields[/SIZE]
[SIZE=2]      ApXL.ActiveCell = fld.Name[/SIZE]
[SIZE=2]      ApXL.ActiveCell.Offset(0, 1).Select[/SIZE]
[SIZE=2]  Next[/SIZE]
 
[SIZE=2]  rst.MoveFirst[/SIZE]
 
[SIZE=2]  xlWSh.Range("A2").CopyFromRecordset rst[/SIZE]
 
 
[SIZE=2]  xlWSh.Range("1:1").Select[/SIZE]
[SIZE=2]  ' This is included to show some of what you can do about formatting.  You can comment out or delete[/SIZE]
[SIZE=2]  ' any of this that you don't want to use in your own export.[/SIZE]
[SIZE=2]  With ApXL.Selection.Font[/SIZE]
[SIZE=2]      .Name = "Arial"[/SIZE]
[SIZE=2]      .Size = 12[/SIZE]
[SIZE=2]      .Strikethrough = False[/SIZE]
[SIZE=2]      .Superscript = False[/SIZE]
[SIZE=2]      .Subscript = False[/SIZE]
[SIZE=2]      .OutlineFont = False[/SIZE]
[SIZE=2]      .Shadow = False[/SIZE]
[SIZE=2]  End With[/SIZE]
 
 
[SIZE=2]  ApXL.Selection.Font.Bold = True[/SIZE]
 
 
[SIZE=2]  With ApXL.Selection[/SIZE]
[SIZE=2]      .HorizontalAlignment = xlCenter[/SIZE]
[SIZE=2]      .VerticalAlignment = xlBottom[/SIZE]
[SIZE=2]      .WrapText = False[/SIZE]
[SIZE=2]      .Orientation = 0[/SIZE]
[SIZE=2]      .AddIndent = False[/SIZE]
[SIZE=2]      .IndentLevel = 0[/SIZE]
[SIZE=2]      .ShrinkToFit = False[/SIZE]
[SIZE=2]      .MergeCells = False[/SIZE]
[SIZE=2]  End With[/SIZE]
 
 
[SIZE=2]  ' selects all of the cells[/SIZE]
[SIZE=2]  ApXL.ActiveSheet.Cells.Select[/SIZE]
 
 
[SIZE=2]  ' does the "autofit" for all columns[/SIZE]
[SIZE=2]  ApXL.ActiveSheet.Cells.EntireColumn.AutoFit[/SIZE]
 
 
[SIZE=2]  ' selects the first cell to unselect all cells[/SIZE]
[SIZE=2]  xlWSh.Range("A1").Select[/SIZE]
 
 
[SIZE=2]  [B][COLOR=red]xlW[/COLOR][COLOR=red]B.Close[/COLOR][/B][/SIZE] [B][COLOR=#ff0000]True[/COLOR][/B] 
[SIZE=2]  [/SIZE]
[SIZE=2][COLOR=red][COLOR=black]   rst.Close[/COLOR][/COLOR][/SIZE]
 
 
[SIZE=2]  Set rst = Nothing[/SIZE]
 
 
[SIZE=2]Exit_SendTQ2XLWbSheet: [/SIZE]
[SIZE=2]  Exit Function[/SIZE]
 
 
[SIZE=2]err_handler:[/SIZE]
[SIZE=2]  DoCmd.SetWarnings True[/SIZE]
[SIZE=2]  MsgBox Err.Description, vbExclamation, Err.Number[/SIZE]
[SIZE=2]  Resume Exit_SendTQ2XLWbSheet    [/SIZE]
[SIZE=2]End Function[/SIZE]

And I believe that should get you on your path.

 

[scubadiver007]

Apologies for not replying sooner.

I will have a go at this.