• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 1271
  • Last Modified:

Excel SaveAs xls - Automation Error

I have an excel tool that will take an input excel file and break it out into multiple files, distributing the records into multiple files.
I am trying to add options to save output files as xls or xlsx.  It already saves as csv, and this still works.  I am getting an automation error when I try to save as xls.  This is the syntax of the saveAs command:
wbkNew.SaveAs Filename:=strCompletePathFilename, FileFormat:=56 'xls format  What is wrong with my code?

Thanks, Lynn Parse-Automation-Tool.zip
Option Explicit

Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public strUserName As String, strPassword As String

'Record Parse Automation Tool
'      This tool takes an input excel file, counts the records on sheet 1 and breaks apart the records into
'       groups x number of records in separate csv files.
'       The number of records per output file is determined by user selection on the main tab, cell E12.
' Input Parameters - User selected on the Main tab:
'       1) input file path and file name
'       2) save-to name of the output file
'              This is preceded with "rcdset(x)".
'              x is an incrementing count of the number of output files created.
'              The filename is followed by the year, month, day, hour and minute of the report run.
'       3) save-to location for report - location of output reports
'       4) Number of records per output file

Private Sub CreateRCTExcelReportFile()
    Dim strReportFileName  As String 'E10 - New Report filename
    Dim strCompleteReportFileName As String  ' With date-time stamp
    Dim strInputFolder As String     'E6 - Input Path and File name
    Dim strNewFolder As String       'E12 save-to path for report
    Dim strCompletePathFilename As String    'Final path and filename with date-time stamps
    Dim strfilter As String
    Dim strDestSheet As String
    Dim WB1 As Workbook
    Dim wbkNew As Workbook
    Dim strPasteRange As String
    Dim myRange As Range
    Dim countNonBlank As Long
    Dim RcSetNumber As Long
    Dim BeginCell As Long
    Dim EndCell As Long
    Dim wbkInput As Workbook
    Dim wks As Worksheet
    Dim strInputRange As String
    Dim NumOfRecords As Long
    Dim lngFileType As Long
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set WB1 = ActiveWorkbook
   ' Initialize variables
    lngFileType = Worksheets("Main").Range("N5")  '1-csv or 2-xls output file
    strInputFolder = Worksheets("Main").Range("E6")     'input path and filename
    strReportFileName = Worksheets("Main").Range("E8")   'output filename
    strNewFolder = Worksheets("Main").Range("E10") 'output path
    strfilter = "*.csv"
    NumOfRecords = Worksheets("Main").Range("E12")
    ' If output folder does not exist, create new folder
    If testDir(strNewFolder) = False Then
        newFolder (strNewFolder)
    End If
    'put together filename and path
    Select Case (lngFileType)
        Case 1   'csv
            strCompleteReportFileName = strReportFileName & " " & Format(Now, "yyyymmdd hhmmss") & ".csv"
        Case 2    'xls
            strCompleteReportFileName = strReportFileName & " " & Format(Now, "yyyymmdd hhmmss") & ".xls"
        Case 3     'xlsx
            strCompleteReportFileName = strReportFileName & " " & Format(Now, "yyyymmdd hhmmss") & ".xlsx"
    End Select
     'check for filename
    If IsNull(strReportFileName) Or (strReportFileName) = "" Then MsgBox "Enter a valid filename for output file.", vbCritical, "Error - Report Parameters"
    If Left(strNewFolder, 1) <> "\" Then strNewFolder = strNewFolder & "\"
    'verify input file exists
    If FileExists(strInputFolder) = False Then
        MsgBox "The input file: " & strInputFolder & " does not exist. " & vbCrLf & _
        "Enter a valid path and filename for input file.", vbCritical, "Error - Input File Parameters"
        Exit Sub
    End If
    ' Check that the target folder exists
    If testDir(strNewFolder) = True Then

    ' path and filename of input
    Worksheets("Main").Range("E6").Activate ' only one input file to lookup
    'Set up to copy input and Create Output report

    RcSetNumber = 1
    Set wbkInput = Workbooks.Open(strInputFolder)
    Set wks = Sheets(1)
    BeginCell = 2
    EndCell = NumOfRecords + 1

    countNonBlank = Application.CountA(Range("A:A"))
        Do While BeginCell < countNonBlank
            If countNonBlank > 0 Then
                 'check for filename
                strCompletePathFilename = strNewFolder & "Rcdset" & RcSetNumber & "_" & strCompleteReportFileName
                 Set wbkNew = Workbooks.Add
                wbkNew.Worksheets.Add.Name = "Recordset" & RcSetNumber
                wbkNew.SaveAs Filename:=strCompletePathFilename
                strDestSheet = "Recordset" & RcSetNumber
                strPasteRange = "A1"
                Call inputFileData(strNewFolder, BeginCell, EndCell, wks, strDestSheet, myRange, _
                strInputFolder, "Sheet(1)", strCompletePathFilename, RcSetNumber, lngFileType)
                BeginCell = BeginCell + NumOfRecords     ' next group of records
                EndCell = EndCell + NumOfRecords
                RcSetNumber = RcSetNumber + 1
            End If
 End If
         MsgBox ("The Last Output File is done and has been saved as: " & vbCr & strCompletePathFilename)
         Application.Cursor = xlDefault

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

    Set WB1 = Nothing
    Set wbkNew = Nothing
End Sub

Public Function inputFileData(strNewFolder As String, BeginRecord As Long, _
                        EndRecord As Long, wks As Worksheet, trDestSheet As String, _
                        strCopyRange As Range, strInputFolder As String, _
                        strInputSheet As String, strCompletePathFilename As String, _
                        lngRcdSetCount As Long, afiletype As Long) As Boolean
    Dim wbkInput As Workbook  'origin
    Dim wbkNew As Workbook   'destination
    Dim countNonBlank As Integer
    Dim myRange As Range
    Dim myString As String
    Dim iCols As Long
    Dim checkSheet As Worksheet
    Dim strTitle As String
    Dim arrayTitles() As String
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
  'Check if wbkNew exists
    If wks Is Nothing Then
       MsgBox "Input file does not contain a Recordset tab.", vbCritical, "Import Data"
       Exit Function

        'OPEN input file
        Set wbkInput = Workbooks.Open(strInputFolder)

        'copy 60 records from input
        Range("A" & BeginRecord & ":A" & EndRecord).Select
        Range(Selection, Selection.End(xlToRight)).Select

        'OPEN new excel file
        Debug.Print (strCompletePathFilename)
        Set wbkNew = Workbooks.Open(strCompletePathFilename)
       'check if sheet exists
        myString = "Recordset" & lngRcdSetCount
        On Error Resume Next
        Set checkSheet = Worksheets(myString)
        If Err.Number <> 0 Then
            Set checkSheet = Worksheets.Add
            checkSheet.Name = myString
        End If
        On Error GoTo 0
        'PASTE records
        Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
                    xlNone, SkipBlanks:=False, Transpose:=False

'ActiveWorkbook.SaveAs Filename:= "c:\MyFile.csv", FileFormat:=xlCSV, CreateBackup:=False

    'Insert Row at top of wbkNew for titles

    'Add the column titles
        'SetFocus on first cell of input sheet
          iCols = 0
        'Get titles from input sheet
          Do While Cells(1, iCols + 1).Value <> ""
              Cells(1, iCols + 1).Select
              strTitle = Cells(1, iCols + 1).Value
              ReDim Preserve arrayTitles(iCols) As String
              arrayTitles(iCols) = Cells(1, iCols + 1).Value
              iCols = iCols + 1
        'SetFocus on wbkNew
          iCols = 0
        'Paste the title to wbkNew
          For iCols = 0 To UBound(arrayTitles)
              strTitle = arrayTitles(iCols)
              wbkNew.Worksheets(1).Cells(1, iCols + 1).Value = strTitle
          Next iCols
            Application.CutCopyMode = False
            'format report
             'Call formatReport(strCompletePathFilename, strNewFolder)
    ' Housekeeping
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        wbkInput.Close SaveChanges:=False
                Debug.Print (strCompletePathFilename)
        'save output file
        Select Case (afiletype)
            Case 1   'csv
            Debug.Print (strCompletePathFilename)
                wbkNew.SaveAs Filename:=strCompletePathFilename, FileFormat:=6 'csv format
            Case 2    'xls
                wbkNew.SaveAs Filename:=strCompletePathFilename, FileFormat:=56 'xls format
            Case 3     'xlsx
                wbkNew.SaveAs Filename:=strCompletePathFilename, FileFormat:=51 'xlsx format
        End Select
        Set wbkInput = Nothing
    End If

End Function

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean

  Dim wsSheet As Worksheet

    On Error Resume Next
    Set wsSheet = Sheets(WorksheetName)
    On Error GoTo 0
        If wsSheet Is Nothing Then
            WorksheetExists = False
            WorksheetExists = True
        End If

  Set wsSheet = Nothing

End Function
Function testDir(strNewFolder As String) As Boolean

  ' Check for valid folder path
    If Dir(strNewFolder, vbDirectory) = "" Then
    'Debug.Print (strNewFolder)
      testDir = False
      'MsgBox "Error - No folder" & strNewFolder & " found", vbCritical, "Save Report"
      ' Exit Function
      testDir = True
    End If
End Function

Private Function FileExists(ByVal sPathName As String, Optional Directory As Boolean) As Boolean

    'Returns True if the passed sPathName exist
    'Otherwise returns False
    On Error Resume Next
    If sPathName <> "" Then
        If IsMissing(Directory) Or Directory = False Then
            FileExists = (Dir$(sPathName) <> "")
            FileExists = (Dir$(sPathName, vbDirectory) <> "")
        End If
    End If
End Function

' Function Name:  newFolder(strNewFolder)
'           Checks for a user-specified input folder path and filename
'           Create a new folder for the save-to path of the new results report.
' Parameters:
'           strNewFolder - save-to Path for report
'           strReportFileName - report filename
Function newFolder(strNewFolder As String) As String
    'Check for path
    If IsNull(strNewFolder) Or strNewFolder = "" Then
          MsgBox "Please Enter a valid location of the input files.", vbCritical, "Error - Report Parameters"
         If Dir(strNewFolder, vbDirectory) = "" Then
            MkDir strNewFolder
           'do nothing
        End If
    End If

End Function

Function CheckPassword()
    If Len(strPassword) = 0 Then
        MsgBox "Please enter your password", vbCritical, "Record Parse Automation Tool"
        Call MoveToFileTab("Record Parse Automation.xls", "Main")
        'do nothing, password entered
    End If
End Function

Sub MoveToFileTab(strWorkbookName As String, strWorkSheetName As String)
'Select specific worksheet passed
End Sub

Open in new window

1 Solution
Barry CunneyCommented:
Hi Lynn,
Do you know for definte which SaveAs line in your above code is throwing the error?

What is the exact error?

Also as a test let's break the problem down into something smaller -
1. Take the culprit saveas line of code
2. Create a new workbook
3. Insert a command button in this new workbook
4. Behind this command button insert the culprit saveas line of code but hardcode in any necessary details, such as the full file path

This way we will isolate if it is a problem with your above set up or an environment issue or something else
Rey Obrero (Capricorn1)Commented:
if you are using Excel 2003, try using
          FileFormat:= -4143
Rey Obrero (Capricorn1)Commented:

if you are going to use the codes in different versions see this link for reference

As far as I understand it FileFormat is optional in the SaveAs, so try it without:

wbkNew.SaveAs Filename:=strCompletePathFilename

LambelAuthor Commented:
Thanks much.  That's what I needed.
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Tackle projects and never again get stuck behind a technical roadblock.
Join Now