David G
David G

Reputation: 2347

Detect if a specific workbook is opened/exists, and copy/rename a template to its name if not

What I want to do

My company uses a tool that needs to be fed with Excel files. These excel files are all based on the same template - which I conveniently named CustomTemplate.xls .

I created a macro which looks at a long list of suppliers and parts, and determines which of them are not in our system. I now want to have a macro that automates as much as possible the process by which templates are created.

We have around 20 different suppliers. Each supplier must have its own template (file), and the parts it supplies will be in that file. Therefore, I need to:

1 - Verify that CustomTemplate_SupplierA.xls exists or is opened already. If not, create a copy from Customtemplate.xls and name it that way.

2 - Fill that template in with my info

What I have

I looked at this: Detect whether Excel workbook is already open And this: Copying and renaming unopened workbook in excel

It led me to create this:

Sub templateFiller(FirstDate As Variant, FinalDate As Variant, LigneExtract As Integer)
    Debug.Print "template to be filled with:  " & FirstDate & " " & FinalDate & " info on row " & LigneExtract

    Dim wbk As Workbook
    Dim TemplatePath As String
    Dim wbPath As String
    Dim supplier As String
    Dim lastline As Integer
    'Setting the appropriate names:
    TemplatePath = "O:\08_Lean_Eng\10_On_going\David\Soldier's Pond\MDR\Templates\TemplateCustom.xls"
    supplier = SupDocs.Range("BM" & LigneExtract).Value

    wbPath = Mid(TemplatePath, 1, Len(TemplatePath) - 4) & "_" & supplier & ".xls"

    'Verifying that the workbook is opened:

    If IsWorkBookOpen(wbPath) = False Then
        FileCopy TemplatePath, wbPath
    End If

    Set wbk = Workbooks.Open(wbPath)

    'Goes to last line and fills in my info

    lastline = wbk.Sheets("DL001").Range("A").End(xlUp).Row

    wbk.Sheets("Dl001").Range("A" & lastline) = LigneExtract

End Sub

Function IsWorkBookOpen(FileName As String)
    Dim ff As Long, ErrNo As Long

    On Error Resume Next
    ff = FreeFile()
    Open FileName For Input Lock Read As #ff
    Close ff
    ErrNo = Err
    On Error GoTo 0

    Select Case ErrNo
    Case 0:    IsWorkBookOpen = False
    Case 70:   IsWorkBookOpen = True
    Case Else: Error ErrNo
    End Select
End Function

Which resulted in an error at the Case Else in the function. I assumed this meant the workbook did not exist and the function only worked when the workbook existed, so I went to this site http://www.ozgrid.com/VBA/IsWorkbookOpen.htm and used a slightly DoesWorkBookExist function like so:

Function DoesWorkBookExist(wbpath) As Boolean
Dim i As Integer
    With Application.FileSearch
        .LookIn = "O:\08_Lean_Eng\10_On_going\David\Soldier's Pond\MDR\Templates"
        .FileName = Mid(wbpath, 63)
            If .Execute > 0 Then 'Workbook exists
                DoesWorkBookExist = True
            Else 'There is NOt a Workbook
                DoesWorkBookExist = False
            End If
    End With
End Function

Calling it from the sub instead of the previous function. I get an error on Appliction.FileSearch:

"This object does not support that function" (translated like I could)

Are any of these two functions needed for what I am doing? Is there a simpler way, or am i doing something wrong which causes these errors?

EDIT: Final code (works like a charm)

Sub templateFiller(FirstDate As Variant, FinalDate As Variant, LigneExtract As Integer)
    Debug.Print "template to be filled with:  " & FirstDate & " " & FinalDate & " info on row " & LigneExtract
    Debug.Print "supplier's name: " & SupDocs.Range("BM" & LigneExtract).Value
    Dim wbk As Workbook
    Dim TemplatePath As String
    Dim wbpath As String
    Dim supplier As String
    Dim lastline As Integer
    Dim wbname As String

    TemplatePath = "O:\08_Lean_Eng\10_On_going\David\Soldier's Pond\MDR\Templates\TemplateCustom.xls"
    supplier = SupDocs.Range("BM" & LigneExtract).Value

    wbpath = Mid(TemplatePath, 1, Len(TemplatePath) - 4) & "_" & supplier & ".xls"
    wbname = Mid(wbpath, 63)

    'Vérifie que le workbook a remplir est ouvert
        'Ouvre si non
    If Dir(wbpath) <> "" Then
        If IsWorkBookOpen(wbpath) = False Then
            FileCopy TemplatePath, wbpath
            End If
        Else
            MsgBox wbpath & " File Not found"
            Exit Sub
    End If

    If IsWorkBookOpen(wbpath) = False Then
        Set wbk = Workbooks.Open(wbpath)
    Else
        Set wbk = Workbooks(wbname)
    End If

    'Va à la dernière ligne vide
    'Inscrit infos

    lastline = wbk.Sheets("DL001").Range("A65000").End(xlUp).Row + 1

    wbk.Sheets("Dl001").Range("A" & lastline) = LigneExtract

End Sub

Function IsWorkBookOpen(filename As String) As Boolean
    Dim ff As Long, ErrNo As Long

    On Error Resume Next
    ff = FreeFile()
    Open filename For Input Lock Read As #ff
    Close ff
    ErrNo = Err
    On Error GoTo 0

    Select Case ErrNo
    Case 0:    IsWorkBookOpen = False
    Case 70:   IsWorkBookOpen = True
    Case Else: Error ErrNo
    End Select
End Function

Upvotes: 2

Views: 223

Answers (1)

Siddharth Rout
Siddharth Rout

Reputation: 149305

Which resulted in an error at the Case Else in the function.

You are getting that error because IsWorkBookOpen is not able to find the file.

Replace

If IsWorkBookOpen(wbPath) = False Then
    FileCopy TemplatePath, wbPath
End If

with

If Dir(wbPath) <> "" Then
    If IsWorkBookOpen(wbPath) = False Then
        FileCopy TemplatePath, wbPath
    End If
Else
    MsgBox wbPath & " File Not found"
    Exit Sub
End If

And try again.

Tim has already answered in the comment below the question that the Application.FileSearch which has been discontinued from Excel 2007.

Edit

1 - Verify that CustomTemplate_SupplierA.xls exists or is opened already. If not, create a copy from Customtemplate.xls and name it that way.

2 - Fill that template in with my info

This is how I would do it (untested). I am using hard coded values for demonstration purpose.

Sub Sample()
    Dim wbPath As String, TemplatePath As String
    Dim wb As Workbook
    
    TemplatePath = "C:\TemplateCustom.xls"
    wbPath = "C:\CustomTemplate_SupplierA.xls"
    
    If Dir(wbPath) <> "" Then
        '~~> If File is Closed
        If IsWorkBookOpen(wbPath) = False Then
            FileCopy TemplatePath, wbPath
            Set wb = Workbooks.Open(wbPath)
        '~~> If File is open
        Else
            Set wb = Workbooks("CustomTemplate_SupplierA.xls")
        End If
        
        With wb.Sheets("Sheet1")
            '
            '~~> Write Something
            '
        End With
    Else
        MsgBox wbPath & " File Not found"
        Exit Sub
    End If
End Sub

Upvotes: 2

Related Questions