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并使用了一个稍微有点DoWorkBookExist函数：

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

导致函数中的Case Else出现错误。

您收到该错误是因为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

再试一次。

蒂姆已在下面的评论中回答了{2007离开Excel 2007已Application.FileSearch的问题。

修改

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

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

我就是这样做的（未经测试）。我使用硬编码值进行演示。

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

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

1 个答案: