ソースブックのいずれかが開いている場合、vbaコードの実行を停止できますか？

Question

特定のフォルダに保存されているすべてのブックの最初のワークシートが1つのブックに統合されている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