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文件处于打开状态，因此会使脚本生效。

示例：

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

如果其中一个源工作簿打开，我可以停止运行vba代码吗？

3 个答案: