Which Export to Excel Process is best to copy data into an existing formatted spreadsheet?

@Isaac isn't that because of this line
wb.Close False
?
 
How do you all go about testing the various scenarios this code is supposed to cover? How do you keep yourself organized?

At this point, the export code works (worked).
So, what I have to test is the various safety/error checks that got added to the code like missing files or files that should have been deleted. Here's the function/subs:

Code: 
Function FileExists(FilePath As String) As Boolean
Dim TestStr As String
    TestStr = ""
    On Error Resume Next
    TestStr = Dir(FilePath)
    On Error GoTo 0
    If TestStr = "" Then
        FileExists = False
    Else
        FileExists = True
    End If
End Function
Code: 
Public Sub FileCopy(SrcPath As String, SrcName As String, DestName As String, Optional DestPath As String)
Dim fso As Object
If IsMissing(DestPath) Then
    DestPath = SrcPath
End If

If FileExists(SrcPath & SrcName) = False Then
    MsgBox ("Copy Cancelled - Source File Does Not Exist")
ElseIf FileExists(DestPath & DestName) = True Then
    MsgBox ("Copy Cancelled - Destination File Already Exists")
Else
    Set fso = VBA.CreateObject("Scripting.FileSystemObject")
    fso.CopyFile SrcPath & SrcName, DestPath & DestName
End If
End Sub
Code: 
Function IsFileOpen(fileName As String)
Dim fileNum As Integer
Dim errNum As Integer

'Allow all errors to happen
On Error Resume Next
fileNum = FreeFile()

'Try to open and close the file for input. Errors mean the file is already open
Open fileName For Input Lock Read As #fileNum
Close fileNum
errNum = Err

'Do not allow errors to happen
On Error GoTo 0

'Check the Error Number
Select Case errNum
    Case 0      'errNum = 0 means no errors, therefore file closed
    IsFileOpen = False
    
    Case 70     'errNum = 70 means the file is already open
    IsFileOpen = True

    Case Else    'Something else went wrong
    IsFileOpen = errNum
End Select
End Function

Code: 
Public Sub FormatList(Source As String, Template As String, SheetName As String)
On Error GoTo ErrHandler
'Coded using late binding so instances are defined as objects and excel specific types are enumerated
'Variable Definitions
Dim excelApp As Object
Dim wbSource As Object, wbTemplate As Object
Dim wsDestination As Object, wsSource As Object, wsTemplate As Object
Dim rngDestination As Object, rngTemplate As Object
Dim lastrow As Long, lastcol As Long

'Transfer data from export source to copy of template file
Set excelApp = CreateObject("Excel.Application")
excelApp.Application.Visible = True
Set wbSource = excelApp.Workbooks.Open(Source)                                                                  'Open Source workbook
Set wbTemplate = excelApp.Workbooks.Open(Template)                                                            'Open Template copy
Set wsTemplate = wbTemplate.Worksheets(1)                                                                     'Set Template sheet
Set wsSource = wbSource.Sheets(1)                                                                               'Set source workbook sheet
wsSource.Copy after:=wbTemplate.Worksheets(wbTemplate.Worksheets.Count)                                       'Copy source worksheet to end of template copy
wbSource.Close
Set wsDestination = wbTemplate.Worksheets(wbTemplate.Worksheets.Count)                                        'Set New List Destination Sheet
lastrow = wsDestination.UsedRange.Rows.Count
lastcol = wsDestination.UsedRange.Columns.Count
Set rngDestination = wsDestination.Range(wsDestination.Cells(2, 1), wsDestination.Cells(lastrow, lastcol))      'Set destination data range
Set rngTemplate = wsTemplate.Range(wsTemplate.Cells(2, 1), wsTemplate.Cells(lastrow, lastcol))              'Set template data range
rngTemplate.Cells.Value = rngDestination.Cells.Value                                                           'Set template data equal to destination data
wsDestination.Delete

'Format alternating row shading, column borders and column widths for new range of data
With rngTemplate
    .Borders(11).LineStyle = 1
    .FormatConditions.Delete
    .FormatConditions.Add Type:=2, Formula1:="=MOD(ROW(),2)"
    With .FormatConditions(1).Interior
        .ColorIndex = 15
        .TintAndShade = 0
    End With
    .Columns.AutoFit
End With

ExitHandler:
excelApp.Workbooks.Close
excelApp.Quit
Set excelApp = Nothing
Exit Sub

ErrHandler:
Call ErrProcessor
Resume ExitHandler
End Sub

Code: 
Public Sub ExportQuery(QueryName As String, ExportPath As String, Optional expFileName As String)
On Error GoTo ErrHandler
ProcName = "ExportQuery"

If IsMissing(expFileName) Then
    expFileName = QueryName
End If
DoCmd.TransferSpreadsheet _
    TransferType:=acExport, _
    SpreadsheetType:=acSpreadsheetTypeExcel12Xml, _
    TableName:=QueryName, _
    fileName:=ExportPath & expFileName & ".xlsx"

ExitHandler:
'Insert any code that needs to come after error handler here
Exit Sub

ErrHandler:
Call ErrProcessor
Resume ExitHandler
End Sub
 
Here is the main code for exporting:

Code: 
Private Sub btnExport_Click()
On Error GoTo ErrHandler
'Variable Definitions
Dim qryExport As String
Dim exportFileName As String, exportFilePath As String, exportFile As String
Dim templateFileName As String, templateFilePath As String, templatefile As String
Dim listFileName As String, listFilePath As String, listFile As String
Dim listArchivePath As String, listArchiveName As String, listArchive As String
Dim ShtName As String
Dim ProcCheck As Long
Dim fso As Object
Dim FileDate As String

ProcCheck = 0       'Each positive check increments

'Query Export Information
qryExport = "qryAvailability"
exportFileName = "qryAvailability"
exportFilePath = "**REDACTED**"
exportFile = exportFilePath & exportFileName

'Template Information
templateFileName = "UATemplate.xlsm"
templateFilePath = exportFilePath
templatefile = templateFilePath & templateFileName

'List Information
ShtName = "UNIT AVAILABILITY LIST"
listFileName = "UNIT AVAILABILITY LIST.xlsx"
listFilePath = "**REDACTED**"
listFile = listFilePath & listFileName

'Archive Information
listArchivePath = "**REDACTED**"
FileDate = Format(Now, "yyyy-mm-dd hh-mm-ss")
listArchiveName = Left(listFileName, Len(listFileName) - 5) & " " & FileDate & ".xlsx"
listArchive = listArchivePath & listArchiveName

If FileExists(exportFile) = False Then       'If export file already exists, query export will fail.
    ProcCheck = ProcCheck + 1
Else
    Dim answer As Boolean
    answer = MsgBox("The exported file already exists.  Do you want to delete it?" _
        , vbQuestion + vbYesNo + vbDefaultButton2 _
        , "WARNING: EXPORT FILE ALREADY EXISTS")
    If answer = vbNo Then
        MsgBox ("Ok.  Aborting Export.")
    Else
        'Delete old export file if it exists
        Set fso = CreateObject("Scripting.FileSystemObject")
        fso.DeleteFile exportFile
        Set fso = Nothing
        ProcCheck = ProcCheck + 1
    End If
End If
        
'Check If Current List Open
If IsFileOpen(listFile) = True Then
    MsgBox ("Cannot export. Current list is in use.")
Else
    ProcCheck = ProcCheck + 1
End If
        
If ProcCheck = 2 Then
    'Rename old list and move to archive
    'This step is first to minimize time between checking if this file is open and attempting to delete it
    If FileExists(listFile) Then
        Call FileCopy(listFilePath, listFileName, listArchiveName, listArchivePath)
        If FileExists(listArchive) Then
            Set fso = CreateObject("Scripting.FileSystemObject")
            fso.DeleteFile listFile
            Set fso = Nothing
        End If
    End If
    
    'Export the query to an excel spreadsheet
    Call ExportQuery(qryExport, exportFile, exportFileName)

    'Copy the template file
    Call FileCopy(templateFilePath, templateFileName, listFileName)
    
    'Transfer data from export to new copy of the template
    Call FormatList(exportFile, templatefile, ShtName)
    
    'Delete the generated export file
    Set fso = CreateObject("Scripting.FileSystemObject")
    fso.DeleteFile exportFile
    Set fso = Nothing
        
    'Copy New List to List Location
    Call FileCopy(templateFilePath, listFileName, listFileName, listFilePath)
    
    'Acknowledgment Message
    MsgBox ("Export Successful!")
End If

ExitHandler:
'needed code
Exit Sub

ErrHandler:
Call ErrProcessor
Resume ExitHandler
    
End Sub
 
I've run into my first issue. The following code isn't working as I thought it would. I'm not passing an optional argument to my sub and want to set it to be one of the other passed arguments. However, when I debug.print on DestPath after the If/Then statement it is still empty. Debug.Print on SrcPath displays correctly.

Code: 
Public Sub FileCopy(SrcPath As String, SrcName As String, DestName As String, Optional DestPath As String)
Dim fso As Object
If IsMissing(DestPath) Then
    DestPath = SrcPath
End If

...More Code...
 
Answer: certain variable types don't have a "missing" flag. Changed to As Variant and its working now.
 
I would have checked the length?
 
You must log in or register to reply here.

Similar threads

M
Export 2 forms to same spreadsheet
Replies
7
Views
466
mounty76
M
S
REPORT TO EXCEL FORMAT
Replies
8
Views
283
Gasman
Gasman
R
Solved Import Excel file into existing table with an autonumber primary key field
Replies
6
Views
494
Isaac
Isaac
B
  • Question Question
export and transpose problem
Replies
8
Views
549
Pat Hartman
P
H
How to insert some data from Excel spreadsheet and the other data from Access combo boxes
Replies
6
Views
656
Pat Hartman
P

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom