Creating Excel files from MS Access

This routine is used to create an inventory forecast, which displays a 52 week forecast based on Sales orders MRP forecast and scheduled PO’s.

Function OpenWritetoXLS_QCS(tmpFiletoOpen, tmpFirstWeek, tmpLastWeek)
Dim objXL As Object
Dim strWhat As String, boolXL As Boolean
Dim objWkb As Object
Dim objSht As Object
Dim rst As Recordset, tmpRange, tmpRangeCount, tmpGonePast, tmpPosition, tmpOffset, I, tmpColumn
tmpGonePast = False
    Set rst = CurrentDb.OpenRecordset("Select * from tblTmpXLFile order by Id") ' this is my access table that contains the records I want to insert into excel
    If rst.RecordCount > 0 Then
        rst.MoveFirst
    Else
        Set rst = Nothing
        MsgBox ("Nothing to export to excel")
        Exit Function
    End If
    tmpRange = ""

    If fIsAppRunning("Excel") Then
        Set objXL = GetObject(, "Excel.Application")
        boolXL = False
    Else
        Set objXL = CreateObject("Excel.Application")
        boolXL = True
    End If
    
    'now open file
  With objXL
  
    .Visible = True
    Set objWkb = .Workbooks.Open(tmpFiletoOpen)
    On Error Resume Next
    Set objSht = objWkb.Worksheets("SHEETNAME")
    If Not Err.Number = 0 Then
      Set objSht = objWkb.Worksheets.Add
      objSht.Name = "SHEETNAME"
    End If
    
    objWkb.Worksheets("SHEETNAME").Activate
    
    objSht.Range("C1").Select
    objXL.ActiveCell.offset(0, 0) = tmpFirstWeek
    
    Err.Clear
    
    On Error GoTo 0
    tmpRangeCount = 1
    With objSht
        Do While Not rst.EOF
            tmpPosition = rst!Cellref ' this notes the line within the Excel model that I want to populate
            'reset to new position
            Select Case tmpPosition
                Case 6
                    .Range("B4").Select
                    tmpOffset = 3
                Case 8
                    .Range("B5").Select
                    tmpOffset = 4
                Case 9
                    .Range("B6").Select
                    tmpOffset = 5
                Case 20
                    .Range("B12").Select
                    tmpOffset = 11
                Case 30
                    .Range("B13").Select
                    tmpOffset = 12
                Case 35
                    .Range("B14").Select
                    tmpOffset = 13
            End Select
            
            'Find out what row we should go to
            tmpColumn = Val(rst!rptLabel)
            tmpColumn = tmpColumn - tmpFirstWeek + 1
            
            If Val(rst!rptLabel) = 0 Then
                objXL.ActiveCell.offset(0, 0) = rst!FIELDNAME
            Else
                objXL.ActiveCell.offset(0, tmpColumn) = rst!FIELDNAME
            End If
            rst.MoveNext
        Loop
    End With

  'update Parameters
    Set objSht = objWkb.Worksheets("Parameters")
    If Not Err.Number = 0 Then
      Set objSht = objWkb.Worksheets.Add
      objSht.Name = "Parameters"
    End If
    
    objWkb.Worksheets("Parameters").Activate
    
    objSht.Range("A1").Select
    objXL.ActiveCell.offset(0, 0) = "Year"
    objXL.ActiveCell.offset(0, 1) = Forms![frmExport]![txtYear]
    objXL.ActiveCell.offset(1, 0) = "Overdue Week"
    objXL.ActiveCell.offset(1, 1) = Forms![frmExport]![txtOverDue]
    objXL.ActiveCell.offset(2, 0) = "Start of Month"
    objXL.ActiveCell.offset(2, 1) = Forms![frmExport]![txtStartofMonth]
    
    objXL.ActiveCell.offset(3, 0) = "First Week"
    objXL.ActiveCell.offset(3, 1) = Forms![frmExport]![txtFirstWeek]
    
    objXL.ActiveCell.offset(3, 0) = "Last Week"
    objXL.ActiveCell.offset(3, 1) = Forms![frmExport]![txtLastWeek]
    
  End With
  
  objWkb.Close savechanges:=True
  
  Set objSht = Nothing
  Set objWkb = Nothing
  Set objXL = Nothing
  Set rst = Nothing
  
End Function