The following is not pretty but it will do what you ask. You might want to print this out as it is a little long as has today. Good luck!
Dim i As Integer
Dim j As Integer
Dim j1 As Integer
Dim prm As Parameter
Dim MyFile, Myfile2, MyDirectory
Dim MyPath
Dim ExcelWasRunning, brunning As Boolean
Dim Message
Dim sheet As Object
Dim strSheetName, strVar As String
Dim xFile As Object
Dim stddocName2 As String
Dim strName, strProperty As String
Dim rstFUTS As QueryDef
Dim rsIrpIfta As QueryDef
Dim rst As Recordset
Dim rsFolder As Recordset
Dim rsIRP As Recordset
Dim dbsCur As Database
Dim CurrentField As Variant
Dim FieldCount As Integer
Dim FieldName As String
strSheetName = "IRPvsIFTA"
ExcelWasRunning = False
brunning = False
If Forms!frmIRPvsIFTA!LblWait.Visible = False Then
Forms!frmIRPvsIFTA!LblWait.Visible = True
End If
Message = MsgBox("Please Wait Until The IRP vs IFTA Reported Information Is Inserted Into The Audit File. This May Take Several Minutes.", vbOKOnly)
Set dbsCur = CurrentDb()
Docmd.Hourglass True
Set rstFUTS = dbsCur.QueryDefs("qryFuts")
Set rst = rstFUTS.OpenRecordset(dbOpenSnapshot)
Set rsFolder = DBEngine(0).Databases(0).OpenRecordset("tblRegistrantName")
Forms!frmRegistrantName!txtFuts.Value = rst!Futs_No
rst.Close
rstFUTS.Close
Set rsIrpIfta = dbsCur.QueryDefs("qryIRPvsIFTARep_Crosstab")
For Each prm In rsIrpIfta.Parameters
prm.Value = Eval(prm.Name)
Next prm
On Error Resume Next
Set xFile = GetObject(, "Excel.Application")
If Err.Number = 0 Then
ExcelWasRunning = True
xFile.Application.ActiveWorkbook.Save
xFile.Application.ActiveWorkbook.Close
Message = MsgBox("An Excel File Was Open, Click OK, The File Will Be Saved And Closed.", vbOKOnly)
End If
Err.Clear
If xFile Is Nothing Then
Set xFile = CreateObject("Excel.Application")
brunning = False
End If
xFile.Application.Workbooks.Open "C:\Program Files\Microsoft Office\Office11\XLStart\Personal.xls"
xFile.ActiveWindow.Visible = False
xFile.Visible = False
xFile.Application.Workbooks.Open "C:\My Documents\" & rsFolder!FolderName & "\" & rsFolder!AuditName
'Xfile.ActiveWindow.Visible = True
'Xfile.Visible = True
For i = 1 To xFile.Application.Sheets.Count
strName = xFile.Application.Sheets(i).Name
If strName = strSheetName Then GoTo SheetCreated:
Next i
xFile.ActiveWorkbook.Sheets.Add
xFile.ActiveSheet.Name = strSheetName
xFile.Application.ActiveWorkbook.Sheets("IRPvsIFTA").Move After:=xFile.Application.Worksheets("Options")
SheetCreated:
strProperty = xFile.Application.Calculation '-4105 seems to be numertic value for xlCalculationAutomatic
If xFile.Application.Calculation = xlCalculationAutomatic Then
xFile.Application.Calculation = xlCalculationManual
End If
'Clean Out Any Old Info On Sheet
xFile.ActiveWorkbook.Sheets(strSheetName).Range("A1:F100").Value = ""
'XXXXX Area Where The Reported IFTA Info Will Be Dropped On The IRPvsIFTA worksheet.
Set sheet = xFile.ActiveWorkbook.Sheets(strSheetName).Range("A1")
Set rsIRP = rsIrpIfta.OpenRecordset(dbOpenSnapshot)
FieldCount = rsIRP.Fields.Count
For j1 = 0 To FieldCount - 1
FieldName = rsIRP.Fields(j1).Name
xFile.ActiveWorkbook.Sheets(strSheetName).Cells(1, (j1 + 1)).Value = FieldName
Next j1
j = 2
Do Until rsIRP.EOF
For i = 0 To rsIRP.Fields.Count - 1
CurrentField = rsIRP(i)
sheet.Cells(j, i + 1).Value = CurrentField
Next i
rsIRP.MoveNext
j = j + 1
Loop
If xFile.Application.Calculation = xlCalculationManual Then
xFile.Application.Calculation = xlCalculationAutomatic
End If
'Xfile.Application.ActiveWorkbook.Save
xFile.Application.ActiveWorkbook.Close savechanges:=True
xFile.Application.Quit
Forms!frmIRPvsIFTA!LblWait.Visible = False
Docmd.Hourglass False
Message = MsgBox("Done, Open The Excel File To View The IRPvsIFTA worksheet.", vbOKOnly)
rsIRP.Close
rsFolder.Close
Set rsIRP = Nothing
Set rsFolder = Nothing
Set rst = Nothing
Set rstFUTS = Nothing
Set dbsCur = Nothing
