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
Leave a Reply
Want to join the discussion?Feel free to contribute!