Saving Xport to Excel file

J

Justin

I need some assistance
I have a database where I need to export a table to excel. One of my
coworkers gave me this code where it takes the data from table and export it
to excel, and placing it whereever. now my problem is that whenever we do the
exporting, it is going to that same sheet and keeps adding it. I've tried to
add the save-as dialog window but it seem not to work, cause it is still
going to that same sheet.
I'm trying to have that sheet just be the template but have a save-as dialog
window open to have the user give the file a name and not overwirte the
template

MAybe im doing something wrong, please help
here is the code Im using:
Private Sub cmdExport_Click()
On Error GoTo LocalError

Dim WhereTo As String
Dim ProjectID As String
Dim rsExporting As DAO.Recordset
Dim NoOfRecords As Integer
Dim NoOfWorksheets As Integer
Dim stDocName As String
Dim strFilter As String
Dim strSaveFileName As String

strFilter = ahtAddFilterItem(strFilter, "Excel File (*.xls)", "*.xls")
strSaveFileName = ahtCommonFileOpenSave( _
OpenFile:=False, _
Filter:=strFilter, _
Flags:=ahtOFN_OVERWRITEPROMPT Or ahtOFN_READONLY)
Me.import = strSaveFileName

WhereTo = [Forms]![form1]![import]

If WhereTo = "NoFile" Then Exit Sub

DoCmd.RunMacro "BDCappend"
Set rsExporting = CurrentDb.OpenRecordset("BDC")

With rsExporting
..MoveLast
NoOfRecords = rsExporting.RecordCount
..MoveFirst
End With


'================================================= =====
'Insert the data from the temptable to the excel sheet
'================================================= =====

Dim CellRef As Integer
Dim NoOfLoops As Integer

openexcel ("C:\Documents and Settings\James\Desktop\New Folder\Logistics CDI
v01")
xl.UserControl = False 'Doesnt allow user any control whilst we run our update
xl.Worksheets.SELECT 'Select the BDC Worksheet

'This section inserts the correct number of rows into the body of the
spreadsheet
NoOfLoops = NoOfRecords - 1
Do Until NoOfLoops = 0
xl.Rows("13:13").SELECT
xl.Selection.Insert Shift:=xlDown
xl.Rows("12:12").SELECT
xl.Selection.Copy 'need to copy the forumlas too, so cant just insert new rows
xl.Rows("12:14").SELECT
xl.ActiveSheet.Paste
xl.Application.CutCopyMode = False 'takes the flashing cell thing away
NoOfLoops = NoOfLoops - 1
Loop

'This Loop section inserts the Data
CellRef = 12 'Starts at 12 because that is the start of the area i want to
insert into
NoOfLoops = NoOfRecords
With rsExporting
..MoveFirst
Do Until NoOfLoops = 0
xl.Range("A" & CellRef & "").Value = rsExporting![CDI ID]
xl.Range("B" & CellRef & "").Value = rsExporting![Date]
xl.Range("J" & CellRef & "").Value = rsExporting![Corp]
xl.Range("K" & CellRef & "").Value = rsExporting![Account#]
xl.Range("C" & CellRef & "").Value = rsExporting![Org]
xl.Range("E" & CellRef & "").Value = rsExporting![Locator]
xl.Range("D" & CellRef & "").Value = rsExporting![SubInventory]
xl.Range("H" & CellRef & "").Value = rsExporting![Box Status]
xl.Range("G" & CellRef & "").Value = rsExporting![Serial Number]
xl.Range("F" & CellRef & "").Value = rsExporting![Part #]
xl.Range("I" & CellRef & "").Value = rsExporting![Operator ID]
CellRef = CellRef + 1
NoOfLoops = NoOfLoops - 1
..MoveNext
Loop
End With

xl.UserControl = True 'Give control back to the user
rsExporting.Close

MsgBox "Exporting BDC is completed!", vbOKOnly, "Export Completed"
DoCmd.Close A_FORM, "form1"
xl.Visible = True

LocalExit:
Set xl = Nothing
Set rsExporting = Nothing
Exit Sub

LocalError:
MsgBox Err.Number & vbCr & vbCr & Err.Description
Resume LocalExit

End Sub

=============
openexcel module:
Option Compare Database
Option Explicit

Public xl As Object 'This is how you will refer to the object once it is open

Function openexcel(strLocation)

Set xl = CreateObject("Excel.Application")

xl.Visible = False 'Makes the spreasheet visible. False will let you open
'it behind the scenes

xl.Workbooks.Add strLocation
'xl.Workbooks.Add 'Will Create a new workbook
End Function
 
J

John Nurick

Hi Justin,

One source of your troubles is that you get strSaveFileName and put it
in the strangely-named textbox Me.import - and then do nothing more with
it. I would have expected something like

xl.Workbooks(1).SaveAs strSaveFileName
xl.Workbooks(1).Close

towards the end of the procedure.

Also, the line
If WhereTo = "NoFile" Then Exit Sub
Click to expand...
is clumsy and unreliable. Better to dump the WhereTo variable and use

If Len(strSaveFileName) = 0 Then
'User cancelled the File Save As dialog
Exit Sub
End If




I need some assistance
I have a database where I need to export a table to excel. One of my
coworkers gave me this code where it takes the data from table and export it
to excel, and placing it whereever. now my problem is that whenever we do the
exporting, it is going to that same sheet and keeps adding it. I've tried to
add the save-as dialog window but it seem not to work, cause it is still
going to that same sheet.
I'm trying to have that sheet just be the template but have a save-as dialog
window open to have the user give the file a name and not overwirte the
template

MAybe im doing something wrong, please help
here is the code Im using:
Private Sub cmdExport_Click()
On Error GoTo LocalError

Dim WhereTo As String
Dim ProjectID As String
Dim rsExporting As DAO.Recordset
Dim NoOfRecords As Integer
Dim NoOfWorksheets As Integer
Dim stDocName As String
Dim strFilter As String
Dim strSaveFileName As String

strFilter = ahtAddFilterItem(strFilter, "Excel File (*.xls)", "*.xls")
strSaveFileName = ahtCommonFileOpenSave( _
OpenFile:=False, _
Filter:=strFilter, _
Flags:=ahtOFN_OVERWRITEPROMPT Or ahtOFN_READONLY)
Me.import = strSaveFileName

WhereTo = [Forms]![form1]![import]

If WhereTo = "NoFile" Then Exit Sub

DoCmd.RunMacro "BDCappend"
Set rsExporting = CurrentDb.OpenRecordset("BDC")

With rsExporting
.MoveLast
NoOfRecords = rsExporting.RecordCount
.MoveFirst
End With


'================================================= =====
'Insert the data from the temptable to the excel sheet
'================================================= =====

Dim CellRef As Integer
Dim NoOfLoops As Integer

openexcel ("C:\Documents and Settings\James\Desktop\New Folder\Logistics CDI
v01")
xl.UserControl = False 'Doesnt allow user any control whilst we run our update
xl.Worksheets.SELECT 'Select the BDC Worksheet

'This section inserts the correct number of rows into the body of the
spreadsheet
NoOfLoops = NoOfRecords - 1
Do Until NoOfLoops = 0
xl.Rows("13:13").SELECT
xl.Selection.Insert Shift:=xlDown
xl.Rows("12:12").SELECT
xl.Selection.Copy 'need to copy the forumlas too, so cant just insert new rows
xl.Rows("12:14").SELECT
xl.ActiveSheet.Paste
xl.Application.CutCopyMode = False 'takes the flashing cell thing away
NoOfLoops = NoOfLoops - 1
Loop

'This Loop section inserts the Data
CellRef = 12 'Starts at 12 because that is the start of the area i want to
insert into
NoOfLoops = NoOfRecords
With rsExporting
.MoveFirst
Do Until NoOfLoops = 0
xl.Range("A" & CellRef & "").Value = rsExporting![CDI ID]
xl.Range("B" & CellRef & "").Value = rsExporting![Date]
xl.Range("J" & CellRef & "").Value = rsExporting![Corp]
xl.Range("K" & CellRef & "").Value = rsExporting![Account#]
xl.Range("C" & CellRef & "").Value = rsExporting![Org]
xl.Range("E" & CellRef & "").Value = rsExporting![Locator]
xl.Range("D" & CellRef & "").Value = rsExporting![SubInventory]
xl.Range("H" & CellRef & "").Value = rsExporting![Box Status]
xl.Range("G" & CellRef & "").Value = rsExporting![Serial Number]
xl.Range("F" & CellRef & "").Value = rsExporting![Part #]
xl.Range("I" & CellRef & "").Value = rsExporting![Operator ID]
CellRef = CellRef + 1
NoOfLoops = NoOfLoops - 1
.MoveNext
Loop
End With

xl.UserControl = True 'Give control back to the user
rsExporting.Close

MsgBox "Exporting BDC is completed!", vbOKOnly, "Export Completed"
DoCmd.Close A_FORM, "form1"
xl.Visible = True

LocalExit:
Set xl = Nothing
Set rsExporting = Nothing
Exit Sub

LocalError:
MsgBox Err.Number & vbCr & vbCr & Err.Description
Resume LocalExit

End Sub

=============
openexcel module:
Option Compare Database
Option Explicit

Public xl As Object 'This is how you will refer to the object once it is open

Function openexcel(strLocation)

Set xl = CreateObject("Excel.Application")

xl.Visible = False 'Makes the spreasheet visible. False will let you open
'it behind the scenes

xl.Workbooks.Add strLocation
'xl.Workbooks.Add 'Will Create a new workbook
End Function
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Exporting to Access Help needed 3
Attach Excel Worksheet (Not Workbook) to Email 2
Attache Excel Worksheet (Not Workbook) to Email 2
How to end Excel Process 4
how to populate textbox based on combobox in word from excel 0
Allow for user pressing cancel in File/Save API 1
loop adodb recordset export to excel works but very slow. 1
insert a column in Excel then export data into Access table 0

Top