如果源工作簿之一打开，我可以停止VBA代码运行吗?

Question

我正在使用一个VBA脚本，其中保存在特定文件夹中的所有工作簿的第一个工作表都在一个工作簿中合并。我想要的是，如果运行此脚本时任何源工作簿是打开的，那么我应该得到一个提示，即"源工作簿已打开"，脚本不应运行。

目的地工作表的VBA脚本如下：

Private Sub CommandButton1_Click()
Dim directory As String, fileName As String, sheet As Worksheet, total As Integer
Dim WrdArray() As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
directory = "C:test"
fileName = Dir(directory & "*.xl??")
Application.EnableEvents = False
Do While fileName <> ""
    Workbooks.Open (directory & fileName)
        WrdArray() = Split(fileName, ".")
        For Each sheet In Workbooks(fileName).Worksheets
        Workbooks(fileName).ActiveSheet.Name = WrdArray(0)
            total = Workbooks("import-sheets.xlsm").Worksheets.Count
            Workbooks(fileName).Worksheets(sheet.Name).Copy After:=Workbooks("import-sheets.xlsm").Worksheets(total)
            GoTo exitFor:
        Next sheet
exitFor:
    Workbooks(fileName).Close
    fileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

我感谢您提前的帮助

Answer 1

未经测试，但应该起作用，来源：https://support.microsoft.com/en-us/kb/291295

Function IsFileOpen(filename As String)
Dim filenum As Integer, errnum As Integer
On Error Resume Next   ' Turn error checking off.
filenum = FreeFile()   ' Get a free file number.
' Attempt to open the file and lock it.
Open filename For Input Lock Read As #filenum
Close filenum          ' Close the file.
errnum = Err           ' Save the error number that occurred.
On Error GoTo 0        ' Turn error checking back on.
' Check to see which error occurred.
Select Case errnum
    ' No error occurred.
    ' File is NOT already open by another user.
    Case 0
     IsFileOpen = False
    ' Error number for "Permission Denied."
    ' File is already opened by another user.
    Case 70
        IsFileOpen = True
    ' Another error occurred.
    Case Else
        Error errnum
End Select
End Function

Answer 2

如果要检查是否打开工作簿（Excel文件），请尝试此功能。

Public Function isWbOpened(ByVal wb As String) As Boolean
        Dim workB As Workbook
        isWbOpened = False
        For Each workB In Workbooks
            If workB.FullName = wb Or workB.Name = wb Then      ''FullName : path + filename       Name : filename only
                isWbOpened = True
            End If
        Next workB
    End Function

如果函数返回true，则excel文件是打开的，因此请seke脚本。

示例：

if isWbOpened("theExcelFile.xlsx") then
    msgbox "theExcelFile.xlsx is open"
end if

Answer 3

您可以列举文件夹中的文件，然后测试它们，以查看是否在继续之前打开。请注意 - 以下代码假设您是打开它们的代码，因此，如果打开共享文件，则可能必须对此进行调整

Sub TestFolder()
    Debug.Print XLFileIsOpen("C:Test")
End Sub
Function XLFileIsOpen(sFolder As String) As Boolean
    For Each Item In EnumerateFiles(sFolder)
        If IsWorkBookOpen(CStr(Item)) = True Then XLFileIsOpen = True
    Next Item
End Function
Function EnumerateFiles(sFolder As String) As Variant
    Dim objFSO As Object: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim objFolder As Object: Set objFolder = objFSO.GetFolder(sFolder)
    Dim objFile As Object, V() As String
    For Each objFile In objFolder.Files
        If IsArrayAllocated(V) = False Then
            ReDim V(0)
        Else
            ReDim Preserve V(UBound(V) + 1)
        End If
        V(UBound(V)) = objFile.Name
    Next objFile
    EnumerateFiles = V
End Function
Function IsArrayAllocated(Arr As Variant) As Boolean
    On Error Resume Next
    IsArrayAllocated = IsArray(Arr) And Not IsError(LBound(Arr, 1)) And LBound(Arr, 1) <= UBound(Arr, 1)
End Function
Function IsWorkBookOpen(sFile As String) As Boolean
    On Error Resume Next
    IsWorkBookOpen = Len(Application.Workbooks(sFile).Name) > 0
End Function