[Last Call] Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 1149
  • 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

    Worksheets("Main").Activate
    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

    'OPEN INPUT FILE
    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
                wbkNew.Close
                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
        Loop
 End If
                 
         MsgBox ("The Last Output File is done and has been saved as: " & vbCr & strCompletePathFilename)
         Application.Cursor = xlDefault

'Housekeeping
    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
    
    Else

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

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

        '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
        wbkNew.Worksheets(1).Activate
        wbkNew.Worksheets(1).Range("A1").Select
        ActiveCell.EntireRow.Insert

    'Add the column titles
 
        'SetFocus on first cell of input sheet
          wbkInput.Worksheets(1).Activate
          Sheets(1).Select
          Range("A1").Select
          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
          Loop
          
        'SetFocus on wbkNew
          wbkNew.Worksheets(1).Activate
          Sheets(1).Select
          Range("A1").Select
          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
        
        wbkNew.Close
        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
        Else
            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
    Else
      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) <> "")
        Else
            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"
    Else
         If Dir(strNewFolder, vbDirectory) = "" Then
            MkDir strNewFolder
        Else
           '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")
        End
     Else
        'do nothing, password entered
    End If
End Function


Sub MoveToFileTab(strWorkbookName As String, strWorkSheetName As String)
'Select specific worksheet passed
    Windows(strWorkbookName).Activate
    Sheets(strWorkSheetName).Select
End Sub

Open in new window

0
Lambel
Asked:
Lambel
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
0
 
Rey Obrero (Capricorn1)Commented:
if you are using Excel 2003, try using
          FileFormat:= -4143
0
 
Rey Obrero (Capricorn1)Commented:

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

http://www.rondebruin.nl/saveas.htm
0
 
leonstrykerCommented:
As far as I understand it FileFormat is optional in the SaveAs, so try it without:

wbkNew.SaveAs Filename:=strCompletePathFilename

Leon
0
 
LambelAuthor Commented:
Thanks much.  That's what I needed.
Lynn
0

Featured Post

Vote for the Most Valuable Expert

It’s time to recognize experts that go above and beyond with helpful solutions and engagement on site. Choose from the top experts in the Hall of Fame or on the right rail of your favorite topic page. Look for the blue “Nominate” button on their profile to vote.

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