A couple of useful workbook functions

 2011-07-02    Workbooks    0    224

The built-in method Workbooks.Add creates a new workbook with a predetermined number of worksheets, usually 3, but this can be another number if the user has changed the setting for how many worksheets a new workbook should contain. I really hate to have empty, unused worksheets in my workbooks, and I am fed up with the extra hassle of writing the necessary code lines to make sure that a new workbook contains the number of worksheets I really want it to have. This first function can be used to create a new workbook with a preset number of worksheets in it, up to max 255 worksheets. If you want even more worksheets you have to add them to the workbook afterwards.

Function NewWorkbook(Optional ByVal lngCount As Long = 1) As Workbook
' creates a new workbook with lngCount (1 - 255) worksheets
Dim lngOrgCount As Long
    With Application
        If lngCount > 1 And lngCount < 256 Then
            ' use the custom worksheet count
            lngOrgCount = .SheetsInNewWorkbook
            .SheetsInNewWorkbook = lngCount
            Set NewWorkbook = .Workbooks.Add
            ' reset to the original worksheet count
            .SheetsInNewWorkbook = lngOrgCount
            ' use the users own setting
            Set NewWorkbook = .Workbooks.Add
        End If
    End With
End Function
Sub Example1()
Dim wb As Workbook
    Set wb = NewWorkbook(1) ' creates a new workbook with one worksheet in it
    MsgBox "Count of worksheets in the workbook: " & wb.Worksheets.Count, vbInformation
End Sub
This second function can be used to get a workbook, usually after retrieving a filename from the user with the Application.GetOpenFilename method or reading it from an input cell in a worksheet. The function below will first check if the workbook is already open, if not it will try to open the workbook using the supplied filename.
Function GetWorkbook(strFullFilename As String, Optional blnReadOnly As Boolean = False, _
    Optional blnUpdateLinks As Boolean = False, Optional strPassword As String = vbNullString, _
    Optional blnWorkbookWasOpen As Boolean = False) As Workbook
' returns a Workbook object if the strFullFilename refers to an open workbook or one that can be opened
' if the workbook is already open, blnWorkbookWasOpen will return True
Dim p As Long, strFilename As String
    blnWorkbookWasOpen = False
    If Len(strFullFilename) < 3 Then Exit Function

    strFilename = strFullFilename
    ' determine if strFullFilename contains a folder path
    p = InStrRev(strFullFilename, Application.PathSeparator)
    If p = 0 Then
        p = InStrRev(strFullFilename, "/") ' url location?
    End If
    If p > 0 Then ' contains a full filepath, get the filename only
        strFilename = Mid(strFullFilename, p + 1)
    End If

    On Error Resume Next
    ' check if the workbook is already open
    Set GetWorkbook = Workbooks(strFilename)
    blnWorkbookWasOpen = Not GetWorkbook Is Nothing
    If GetWorkbook Is Nothing Then ' it was not open
        ' try to open the workbook
        Set GetWorkbook = Workbooks.Open(strFullFilename, blnUpdateLinks, blnReadOnly, , strPassword)
    End If
    On Error GoTo 0
End Function
Sub Example2()
Dim strFileName As String, wb As Workbook, blnOpenWB As Boolean
    strFileName = "Excel Workbooks (*.xl*),*.xl*,All Files (*.*),*.*"
    strFileName = Application.GetOpenFilename(strFileName, 1, "Select a workbook:")
    If Len(strFileName) < 6 Then Exit Sub ' no filename returned

    Set wb = GetWorkbook(strFileName, , , , blnOpenWB)
    If wb Is Nothing Then Exit Sub ' no workbook found

    ' do something useful with the open workbook
    With wb
        .Worksheets(1).Range("A1").Formula = "Last Opened: " & Format(Now, "yyyy-mm-dd hh:mm")
        ' if the workbook was open, save changes and close it
        If blnOpenWB Then
            .Close True ' close and save changes
            '.Close False ' close without saving changes
            '.Close ' close and ask the user about saving changes
        End If
    End With
    Set wb = Nothing
End Sub