我希望拥有主要工作簿（WorkbookA），打开第二个工作簿（WorkbookB）并测试其中的值。要匹配的值在WorkbookA的单元格B3中，并且是数字1。在WorkbookB中要测试的范围是“ A：A”。
如果未找到该值，则重新打开WorkbookB供用户编辑（将进行优化以减少打开/关闭的时间，在编辑Workbook B之后将获得有关恢复用户输入的任何想法），并且WorkbookA中的代码循环并重新测试WorkbookB是否仍每10秒打开一次。
在用户编辑WorkbookB以确保存在该值之后，他们将其关闭（欢迎使用其他任何更好的方法来表示它们已完成，因此我无需关闭并重新打开文件。它们很小，因此不是速度问题，似乎效率很低。）
我的假设是代码随后将检测到工作簿已关闭，然后继续执行代码，但是一旦我在工作簿B的右上角选择X，VBA就会停止。
由于多个用户，不希望在personal.xls文件中没有单独的代码。
谢谢， 亚伦
工作簿A中的代码：
Global Const strWBb As String = "C:\Users\ashepherd\Desktop\WorkbookB.xlsx"
Global Const strRng As String = "A:A"
Sub Validate()
' ***************************** CHECK WORKBOOKB FOR 1 IN COLUMN A:A *****************************
' Verify presence on item in second workbook
searchItem = ThisWorkbook.Worksheets("Sheet1").Range("B3").Value
Do While Verify(searchItem, False) = False
Call Verify("", True)
Do While IsWorkBookOpen(strWBb) = True
endTime = DateAdd("s", 10, Now())
Do While Now() < endTime
DoEvents
Loop
Loop
Debug.Print "Workbook closed"
Loop
Debug.Print "search item found"
End Sub
Function Verify(item, OpenOnly As Boolean) As Boolean
' ****************************************************************************
' Open workbook B and verify that presence of item
' ****************************************************************************
Dim wbVerify As Workbook
Dim rng1 As Range
' ************************** OPEN FILE ************************************************
If IsFile(strWBb) Then
Set wbVerify = Application.Workbooks.Open(FileName:=strWBb, UpdateLinks:=False, IgnoreReadOnlyRecommended:=True) ' Open WorkbookB
wbVerify.Worksheets("Sheet1").Select
Else
MsgBox " File path incorrect. Unable to open.", vbCritical
Exit Function
End If
' ************************** TEST FOR ITEM ************************************************
If OpenOnly = True Then ' Only opening the file for read/write. Not testing values.
MsgBox "Opening workbook so values can be added. Close when additions completed."
Else
MsgBox ("Workbook B opened. Testing value for " & item & " in column A:A in Workbook B")
Set rng1 = Range(strRng).Find(item, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
MsgBox item & " found !"
Verify = True
wbVerify.Close
GoTo item_found
Else
MsgBox (item & " not found in column A:A. Closing Workbook B. *****User will be promoted at this point to exit, or re-open the file to modify the values so search value is found in column A:A. Code SHOULD resume when Workbook B is closed. Currently VBA code execution in Workbook A is stopping when the 'X' is selected in top right window of Workbook B*****")
Verify = False
wbVerify.Close
End If
End If
Normal_exit:
Exit Function
item_found:
MsgBox "Verify code complete"
GoTo Normal_exit
End Function
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
Function IsFile(ByVal fName As String) As Boolean
'Returns TRUE if the provided name points to an existing file.
'Returns FALSE if not existing, or if it's a folder
On Error Resume Next
IsFile = ((GetAttr(fName) And vbDirectory) <> vbDirectory)
End Function
最终代码：
Global Const strWBb As String = "C:\Users\ashepherd\Desktop\WorkbookB.xlsx"
Global Const strRng As String = "A:A"
Global Complete As Boolean
Sub Validate()
' ***************************** CHECK WORKBOOK_B FOR 1 IN COLUMN A:A *****************************
' Verify presence on item in second workbook
searchItem = ThisWorkbook.Worksheets("Sheet1").Range("B3").Value
Do While Verify(searchItem) = False
Complete = False
UserForm1.Show vbModeless ' USerform has a single button which changes the global "Complete" variable to true
Do While Complete = False
DoEvents
Loop
UserForm1.Hide
Debug.Print "Manual Edit Complete, retesting"
Loop
End Sub
Function Verify(item) As Boolean
' Modified to close only upon finding search item vs. reopening it.
' ****************************************************************************
' Open workbook B and verify that presence of item
' ****************************************************************************
Dim wbVerify As Workbook
Dim rng1 As Range
' ************************** OPEN FILE ************************************************
If IsFile(strWBb) Then
Set wbVerify = GetWorkbook(strWBb)
If Not wbVerify Is Nothing Then
Debug.Print wbVerify.Name
End If
wbVerify.Worksheets("Sheet1").Select
Else
MsgBox " File path incorrect. Unable to open.", vbCritical
Exit Function
End If
' ************************** TEST FOR ITEM ************************************************
Set rng1 = Range(strRng).Find(item, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
Verify = True
GoTo item_found
Else
MsgBox (item & " not found in column A:A. A pop up form will show. Edit document and then hit RESUME button to continue checking. DO NOT exit via the close icon in the top right window of Excel as the code will stop running.")
Verify = False
End If
Normal_exit:
Exit Function
item_found:
'MsgBox (item & " found in WorkbookB, column A:A. Verify code complete")
wbVerify.Close Savechanges:=True
GoTo Normal_exit
End Function
Function IsFile(ByVal fName As String) As Boolean
'Returns TRUE if the provided name points to an existing file.
'Returns FALSE if not existing, or if it's a folder
On Error Resume Next
IsFile = ((GetAttr(fName) And vbDirectory) <> vbDirectory)
End Function
Public Function GetWorkbook(ByVal sFullName As String) As Workbook
' https://stackoverflow.com/questions/9373082/detect-whether-excel-workbook-is-already-open, modified to add ignorereadonly and update links
Dim sFile As String
Dim wbReturn As Workbook
sFile = Dir(sFullName)
On Error Resume Next
Set wbReturn = Workbooks(sFile)
If wbReturn Is Nothing Then
Set wbReturn = Application.Workbooks.Open(FileName:=sFullName, UpdateLinks:=False, IgnoreReadOnlyRecommended:=True)
End If
On Error GoTo 0
Set GetWorkbook = wbReturn
End Function