vba - 检测是否打开/存在特定工作簿，如果没有，则将模板复制/重命名为其名称

Question

我想做的

我的公司使用的工具需要提供 Excel 文件。这些 excel 文件都基于相同的模板 - 我方便地命名为 CustomTemplate.xls 。

我创建了一个宏，它查看一长串供应商和零件，并确定其中哪些不在我们的系统中。我现在想要一个宏来尽可能地自动化创建模板的过程。

我们有大约 20 家不同的供应商。每个供应商都必须有自己的模板(文件)，它提供的零件将在该文件中。因此，我需要:

1 - 验证 CustomTemplate_SupplierA.xls 是否存在或已打开。如果没有，请从 Customtemplate.xls 创建一个副本并以此命名。

2 - 用我的信息填写该模板

我有什么

我看了这个:Detect whether Excel workbook is already open
而这个:Copying and renaming unopened workbook in excel

它导致我创建了这个:

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

这导致函数中的 Case Else 出现错误。我认为这意味着工作簿不存在并且该功能仅在工作簿存在时才起作用，所以我去了这个网站 http://www.ozgrid.com/VBA/IsWorkbookOpen.htm并像这样使用了一个稍微的 DoesWorkBookExist 函数:

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

从 sub 而不是以前的函数调用它。我在 Appliction.FileSearch 上收到错误消息:

“这个对象不支持那个功能”(我可以翻译)

我正在做的事情是否需要这两个功能中的任何一个？有没有更简单的方法，或者我做错了什么导致这些错误？

编辑:最终代码(像魅力一样工作)

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

Answer 1

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

您收到该错误是因为 IsWorkBookOpen无法找到该文件。
代替

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

和

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

然后再试一次。
蒂姆已经在下面的评论中回答了 Application.FileSearch 的问题。已从 Excel 2007 中停止使用。
编辑

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

这就是我的做法(未经测试)。我使用硬编码值进行演示。

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