Export Multiple Queries to Multiple Worksheets

M

marleyuk

Joined
Feb 16, 2006
Messages
88
Reaction score
0
Ok. I want to export multiple queries to multiple worksheets in access. Im currently having a problem with it. Here is my current attempt at it. If anyone can offer any guidance it would be much appriciated.

Thanks,
Marley.

Code: 
 Function Export_Excel() As Object
 '
 Dim objExc As Excel.Application
 Dim shts As Excel.Worksheet
 Dim wkbk As Excel.Workbook
 Dim Rge As Excel.Range
 Dim Fld As Variant
 '
 Dim cnn As ADODB.Connection
 Dim Rst_1 As New ADODB.Recordset, Rst_2 As New ADODB.Recordset
 Dim SQL_1 As String, SQL_2 As String
 Dim strPath As String, FldName As String
 Dim varRows As Variant
 '
 Dim I As Integer, SheetCount As Integer
 Dim FileName As String, FirstSheet As String
 '
 On Error GoTo Err_Handler
 '
 Set cnn = CurrentProject.Connection
 									   
 SQL_2 = "SELECT TblImportTableTest.TestName FROM TblImportTableTest GROUP BY TblImportTableTest.TestName"  'select the grouped field (address)
 	
  Rst_2.Open SQL_2, cnn, adOpenKeyset, adLockOptimistic
 
 FileName = InputBox("Enter the name of the file to be saved." & Chr(13) & Chr(13) & " The file will be saved in the same path as the DB.")
 strPath = CurrentProject.Path & "\" & FileName & ".xls"   ' save the file on the same path of the db.
 
  
 Set objExc = New Excel.Application
 
 If Len(FileName & "") > 0 Then		  'Only run the file if the input box has a  name of the file
 	  
    Set wkbk = objExc.Workbooks.Add	   'create a new workbook
 
 	Do Until Rst_2.EOF
 		FldName = Rst_2.Fields("TestName")
 		Set shts = wkbk.ActiveSheet
 		wkbk.Sheets.Add				   ' Add a new sheet to copy new data to
 	   Set ExlApp = New Excel.Application
 	Set wkbk = ExlApp.Workbooks.Open(FilePath)
 	ExlApp.Visible = True
 	Set Shts = wkbk.Sheets("summary")
 	With Shts
 		.Range("c14").Value = Rst.Fields("TotalSpillVolume")					   'Number of spills steps > .001
 		.Range("c16").Value = Rst.Fields("Number_Of_Spill_Timesteps_Over_01")	  'Total number of timesteps
 		.Range("c18").Value = Rst.Fields("NumberOfHoursSpill")
 		'.Range("c26").Value
 	End With
 			Next
 		End With
 		
 
 		
 		Set Rge = shts.Cells(2, 1)	 'say where to start copying the data.
 		Rge.CopyFromRecordset Rst_1	  ' Copy the Rst_1 into the worksheet
 		Rst_1.Close					  ' close the recordset before calling it gain.
 		Set Rst_1 = Nothing
 		shts.Columns.AutoFit			' make the columns autofit to fit the data
 		shts.Name = FldName		   'Name the sheet
 			   
 		Rst_2.MoveNext
 	  
 	Loop
 With wkbk
 	FirstSheet = .Sheets(1).Name
 	SheetCount = .Worksheets.Count
 	.Sheets(FirstSheet).Move after:=.Sheets(SheetCount)
 	.Sheets(1).Select
 End With
 	wkbk.Close True, strPath			'Save the worksheets
  
 End If
 		
 'clean up
 objExc.Quit
 Set objExc = Nothing
 Set wkbk = Nothing
 Set Rge = Nothing
 cnn.Close
 Set cnn = Nothing
 
 Exit_Handler:
 	Exit Function
 	
 Err_Handler:
 	Select Case Err.Number
 		Case 1004	  ' do nothing if the user does not decide to replace the file
 	  Resume Exit_Handler
 		Case Else
 			MsgBox Err.Number & "  " & Err.Description
 	End Select
 	
 End Function
 
Back
Top