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

excel vba windows OS How to save a new worksheet

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

2 Solutions
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?

To help you answer TheGreatCO's questions about line 178, Ken Puls has a handy function to identify if a file exists: http://www.excelguru.ca/node/30

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="http://www.rondebruin.nl/saveas.htm"]http://www.rondebruin.nl/saveas.htm[/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

LambelAuthor Commented:
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???

Featured Post

Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

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