excel vba windows OS How to save a new worksheet

Posted on 2011-05-04
Last Modified: 2012-05-11
I need to create a new workbook, search a folder for xls files and for each file found, create a new worksheet, copy in the data, then create a new folder and save the new workbook to it.

Something is wrong with the save-to operation. Any idea?

Option Explicit

' Procedure: Private Sub CreateRCTExcelReportFile()
'       This report tool creates a new excel file for the quarterly RC-T report.
'       The report is a collection of the data input from multiple excel files.
'       The files are located in the folder indicated on the Main tab of this report tool
'       Report tabs will include one for "OH Report", "number of active RL by customer",
'       "Total Active RL" and "Schedule U".
'       Additionally, tabs are created for each customer acct file. The current list
'       of customer accounts is maintained by the user on the MAIN tab of Report Tool.
'       The user also maintains other parameters for the report, including the filepath location
'       for the input files, and the location where the new file is saved to.
' Parameters:
'       input file path
'       customer account numbers
'       save-to name of report
'       save-to location for report
' Preconditions:
'       1) The files for the report must be saved to the folder location indicated on the Main tab.
'       2) Input Files must be named with the following format:
'          "RC-T Report OH Count ccyymmdd*.xls"
'          "RC-T Report OH Count Pool ccyymmdd*.xls"
'          "RC-T Report Schedule Uccyymmdd*.xls"
'          "RC-T Report 809-618824 ccyymmdd*.xls" (one file / each cust acct #)
' Post Condition:
'       Saves a new xls report file to a new folder.
'       The filename includes the year,month,day,hour,minute of the report run.

Private Sub CreateRCTExcelReportFile()

    Dim strTemplateFileName As String
    Dim strTemplateWorkSheetName As String
    Dim strReportFileName As String
    Dim strCompleteName As String
    Dim strfilter As String
    Dim strInputFolder As String
    Dim strNewFilename  As String
    Dim strNewCompleteFilename As String
    Dim strTemp3 As String
    Dim i As Variant
    'Set Template file name
     strTemplateFileName = "RCTResultsReportGenerator.xls"

    'Set Template worksheet name
    ' strTemplateWorkSheetName = "Main"

    'Set New Report File Name
     strReportFileName = Worksheets("Main").Range("E10") & " " & Format(Now, "yyyymmdd hhmmss") & ".xls"

    'Set Filter for file search
     strfilter = "*.xls"

    ' Indicator for user to wait
     ' Application.Cursor = xlWait

    'Pull the save-to name and path for final report
    strInputFolder = Worksheets("Main").Range("E6")
    strNewFilename = Worksheets("Main").Range("E10")
    'creates new folder for report
    strCompleteName = NewReportFolder(strInputFolder, strNewFilename)

    'Call the Folder search function
     Dim strFileList As String
     Dim arrayOfFiles() As String
     ' Creates an array of file names
    arrayOfFiles = FileList(strInputFolder, strfilter)

' Programmer TODO:
' 1)        Done - Create sheets for 3 static reports
' 2)        Done - Create sheets for each Customer Account Number (CAN) listed in range F2:F100 Main tab
' 3)        Done - Loop through files
' 4)        Done - Trim filenames
' 5) Match files to CANs listed on Main tab
' 6) load file data to related sheet
' 7) format sheets consistantly
' 8) Fix hours minutes
' ToDo 5) Programmer ToDo:
'       fix select statement - not working(???)
'       match the files to the worksheets
'       copy the file data to the related worksheets
' assign a name for each file in folder
'   i = 0
'   Do While arrayOfFiles(i) <> ""
'    ReDim Preserve arrayOfFiles(i) As String
'    strTemp3 = arrayOfFiles(i)
'         ' strip off unused filename characters
'         Debug.Print ((Left(strTemp3, 25)))
'        Select Case (strTemp3)
'          Case (Left(strTemp3, 22) = "RC-T Report Schedule U")
'              strTemp3 = "Schedule U"
'          Case (Left(strTemp3, 21) = "RC-T Report Active RL")
'              strTemp3 = "Active RL"
'          Case (Left(strTemp3, 25) = "RC-T Report OH Count Pool")
'              strTemp3 = "OH Count"
'          Case (Left(strTemp3, 22) = "RC-T Report 809-618824")
'              strTemp3 = "809-618824"
'          Case (Left(strTemp3, 22) = "RC-T Report 809-618838")
'              strTemp3 = "809-618838"
'          Case (Left(strTemp3, 22) = "RC-T Report 815-618839")
'              strTemp3 = "815-618839"
'          Case (Left(strTemp3, 22) = "RC-T Report 827-618877")
'              strTemp3 = "827-618877"
'          Case (Left(strTemp3, 23) = "RC-T Report 936-619173")
'              strTemp3 = "936-619173"
'          Case (Left(strTemp3, 22) = "RC-T Report 959-619225")
'              strTemp3 = "959-619225"
'          Case Else
'             MsgBox ("Unrecognized Files - Check input files")
'             Debug.Print ("couldn't match file name")
'        End Select
'     arrayOfFiles(i) = strTemp3
'     i = i + 1
'   Loop

    ' Create an array of Customer Account Numbers from Main tab
    Dim custNum As Variant
    Dim oSheet As Object

    'Load account nums to array
    Dim strArrayCustNums() As String
    i = 0
    For Each custNum In Worksheets("Main").Range("F2:F100").Cells
        If custNum <> "" Then
            ReDim Preserve strArrayCustNums(i) As String
            strArrayCustNums(i) = custNum
            Debug.Print (strArrayCustNums(i))
            i = i + 1
            Exit For
        End If

    Dim wsht As Worksheet
    Dim wbk As Workbook
    Set wbk = Workbooks.Add
    Set wsht = Worksheets.Add
    wsht.Name = "OH Count"
    Set wsht = Worksheets.Add(after:=Worksheets("OH Count"))
    wsht.Name = "number of active RL by customer"
    Set wsht = Worksheets.Add(after:=Worksheets("number of active RL by customer"))
    wsht.Name = "TOTAL_ACTIVE RL"
   ' create a worksheet for each customer account number
    Dim j As Variant
    j = UBound(strArrayCustNums)
    For i = 0 To j
            Debug.Print (strArrayCustNums(i))
            Set wsht = Worksheets.Add(after:=Worksheets(Sheets.Count))
            wsht.Name = strArrayCustNums(i)
  ' delete the generic sheet1, sheet2, sheet3
    Application.DisplayAlerts = False
    Application.DisplayAlerts = True
    'Save the Report WorkBook
      Set wbk = ActiveWorkbook
      Debug.Print (strCompleteName)
      wbk.SaveAs strCompleteName  'Save file

    ActiveWorkbook.SaveAs Filename:=strCompleteName, FileFormat:=xlNormal, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
    wbk.Close 'Close file
    MsgBox ("A new RC-T Results Report File has been saved as: " & "RC-T Results Report " & Format(Now, "yyyymmdd hhnnss") & ".xls")

 Application.Cursor = xlDefault

End Sub

 ' File Folder Search
 ' Returns a string listing files found in strFolder
  Function FileList(strInputFolder As String, Optional strfilter As String = "*.*") As Variant

    Dim strHolder As String
    Dim i As Integer
    Dim strTemp As String
    Dim strTemp2 As String
    Dim arrayFiles() As String

    If Right$(strInputFolder, 1) <> "\" Then
        strInputFolder = strInputFolder & "\"
        strTemp = Dir(strInputFolder & strfilter)
    End If
    ' make sure there are files in the folder
    If strTemp = "" Then
        MsgBox "The folder is empty.", vbCritical, "File Search"
        Exit Function
    End If

   'load filenames into array
      i = 0
      Do While strTemp <> ""
        ReDim Preserve arrayFiles(i) As String
        arrayFiles(i) = strTemp
        i = i + 1
        strTemp = Dir
        Debug.Print (strTemp)
     FileList = arrayFiles

End Function

' this function is not being used
'get file count
Function fileCount(strInputFolder As String, strfilter As String) As Long
    Dim strTemp2 As String
    Dim lngCount As Long
    Dim MyArray(10000) As String
    Dim i As Integer
    strTemp2 = Dir(strInputFolder & strfilter)
    Do While strTemp2 <> ""
        lngCount = lngCount + 1
        strTemp2 = Dir
        MyArray(i) = strTemp2        ' DOESN'T COMPILE!!!!
        Debug.Print (MyArray(i))
        i = i + 1
    fileCount = lngCount

End Function

' Create a new folder for the save-to path of the new results report
Function NewReportFolder(strInputFolder, strNewFilename) As String

    Dim strNewFolder As String
    Dim strcompleteFileName As String
    'Make sure there is a filename and path entered
    If IsNull(Worksheets("Main").Range("E10")) Or Worksheets("Main").Range("E10") = "" Then
        MsgBox "Please Enter a valid filename for output file.", vbCritical, "Error - Report Parameters"
    End If
    If IsNull(Worksheets("Main").Range("E6")) Or Worksheets("Main").Range("E6") = "" Then
          MsgBox "Please Enter a valid location of the input files.", vbCritical, "Error - Report Parameters"
        'Set complete filename and path for new report   strNewFilename = RC-T Results Report 20110503 1535
        strNewFilename = strNewFilename & Format(Date, "yyyymmdd hhmmss")

        'strNewFolder = Q:\DCS\SUPPORT\RC-T\20110331-Results\RC-T Results Report 20110503 1535
        strcompleteFileName = strInputFolder & "-Results" & "\" & strNewFilename
    End If
        NewReportFolder = strcompleteFileName

End Function

Open in new window

Question by:Lambel
    LVL 1

    Accepted Solution

    You say there is something wrong with the save-to operation, is the debug on line 178 printing a valid path and file name?  Does that path exist, is there a file already there with that name.  Also, if you create attempt to a save-as manually, does it save properly?
    LVL 10

    Assisted Solution


    To help you answer TheGreatCO's questions about line 178, Ken Puls has a handy function to identify if a file exists:

    I think you should explicitly state the Fileformat you want to save it as (esp if you are in excel 2007 or later), for example
    'instead of
          wbk.SaveAs strCompleteName  'Save file
          wbk.SaveAs Filename:=strCompleteName, FileFormat:=56
    'see Ron's page for explanation: [url=""][/url]

    Open in new window

    re "is there a file already there with that name?":
    'the below should overcome this issue, if you want to overwrite an existing file...
    Application.DisplayAlerts = False
          wbk.SaveAs Filename:=strCompleteName, FileFormat:=56
    Application.DisplayAlerts = True
    'alternatively, you could use Ken's function to test for the file's existence before using .saveas...

    Open in new window


    Author Comment

    1) The debug.print line 178 looks perfect:
    Q:\DCS\SUPPORT\RC-T\20110331-Results\RC-T Results Report 20110505 115324.xls
    2) The folder is there:
    3) There are no files in the folder
    4) I can successfully manually save to the same folder with the same filename.
    I'm still erroring on the save file function.
    Runtime Error 1004:
    Method "Save-as" of object_Workbook failed

    Any ideas???

    Write Comment

    Please enter a first name

    Please enter a last name

    We will never share this with anyone.

    Featured Post

    Threat Intelligence Starter Resources

    Integrating threat intelligence can be challenging, and not all companies are ready. These resources can help you build awareness and prepare for defense.

    A little background as to how I came to I design this code: Around 5 years ago I designed an add-in that formatted Excel files to a corporate standard, applying different cell colours and font type depending on whether the cells contained inputs,…
    A simple tool to export all objects of two Access files as text and compare it with Meld, a free diff tool.
    With the advent of Windows 10, Microsoft is pushing a Get Windows 10 icon into the notification area (system tray) of qualifying computers. There are many reasons for wanting to remove this icon. This two-part Experts Exchange video Micro Tutorial s…
    Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…

    794 members asked questions and received personalized solutions in the past 7 days.

    Join the community of 500,000 technology professionals and ask your questions.

    Join & Ask a Question

    Need Help in Real-Time?

    Connect with top rated Experts

    15 Experts available now in Live!

    Get 1:1 Help Now