Vba 为excel文件中的单元格设置值打开多个excel文件时出错

我想在outlook中编写一个宏来检查excel文件是否正在打开，如果此文件未打开，请打开它并设置单元格（1,1）的值。否则，如果它正在打开，只需设置单元格（1,1）的值，无需再次打开它。我就是这样做的，它跑得很好

这是我的源代码，可以这样做

Sub test_3()
    Dim objExcel As Object
    Dim WB As Object
    Dim WS As Object
    If (IsWorkBookOpen("C:\Users\sang\Desktop\Book2.xlsm") = True) Then 'check whether is file opening? if yes
        Set objExcel = GetObject(, "Excel.Application")
        objExcel.Visible = True
        Set WB = objExcel.Workbooks("Book2.xlsm")
        WB.Activate
    Else 'file is not opening
        Set objExcel = CreateObject("Excel.Application")
        objExcel.Visible = True
        Set WB = objExcel.Workbooks.Open("C:\Users\sang\Desktop\Book2.xlsm") 'open file
        WB.Activate
    End If
    Set WS = WB.Worksheets("Sheet1")
    WS.Range("A1").Value = "haha" 'set value for cell
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

但我的问题是，当这个文件打开时，其他几个文件也打开了。它无法为单元格设置值并获取错误“下标超出范围”。调试时，错误位于“Set WB=objExcel.Workbooks（“Book2.xlsm”）”。你能告诉我它有什么问题吗？我怎么解决。当我只有一个excel文件时，一切都正常运行，当打开的文件很少时，就会出现问题

---

如果有多个Excel实例处于打开状态，则无法保证

Set objExcel = GetObject(, "Excel.Application") 

将获取打开文件的实例

试试看

Set objExcel = GetObject("C:\Users\sang\Desktop\Book2.xlsm", "Excel.Application")

或者只是

Set objExcel = GetObject("C:\Users\sang\Desktop\Book2.xlsm")

---

如果有多个

Excel.Application

实例在运行，您将遇到问题，但在其他情况下，这将起作用

Sub TestWrite()
    Const FULLNAME As String = "C:\Users\sang\Desktop\Book2.xlsm"

    Dim objExcel As Object, WB As Object, WS As Object
    Set objExcel = getExcelAppication
    objExcel.Visible = True
    Set WB = getWorkbook(objExcel, FULLNAME)

    If WB Is Nothing Then
        MsgBox "File not found: " & FULLNAME, vbInformation, ":("
    Else
        Set WS = WB.Worksheets("Sheet1")
        WS.Range("A1").Value = "haha"
    End If

End Sub

Function getExcelAppication() As Object
    Dim objExcel As Object
    If GetObject("winmgmts:").ExecQuery("select * from win32_process where name='Excel.exe'").Count > 0 Then
        Set objExcel = GetObject(, "Excel.Application")
    Else
        Set objExcel = CreateObject("Excel.Application")
    End If
    Set getExcelAppication = objExcel
End Function

Function getWorkbook(objExcel As Object, FULLNAME As String) As Object
    Dim ShortName As String
    Dim WB As Object, WS As Object
    ShortName = Right(FULLNAME, Len(FULLNAME) - InStrRev(FULLNAME, "\"))

    For Each WB In objExcel.Workbooks
        If WB.Name = ShortName Then
            Set getWorkbook = WB
            Exit Function
        End If
    Next

    Set getWorkbook = objExcel.Workbooks.Open(FULLNAME)

End Function

---

下面的代码也适用于多个打开的Excel实例

为了适应这篇文章而修改的部分代码取自

下面的代码有点长，但除此之外，它工作得非常好（已测试）

---

我确实像你说的那样，但是当我运行时，我得到一个错误“在自动化操作期间找不到类名的文件名”，当我调试它时，它突出显示这一行“Set-objExcel=GetObject”（“C:\Users\sang\Desktop\Book2.xlsm”，“Excel.Application”）。我像你说的那样添加了更多路径。请帮助我找出ITE的问题即使你的帖子得到了回答，请在下面的回答中检查我的（长）代码，如果你打开了多个Excel实例，它也会起作用。我如你所说，但当我运行时，我收到一个错误“在自动化操作期间找不到类名的文件名”，当我调试它时，它会突出显示这一行“Set-objExcel=GetObject（“C:\Users\sang\Desktop\Book2.xlsm”，“Excel.Application”）。我像你说的那样添加了更多的路径。请帮助我找出它有什么问题。该文件肯定在Excel中打开了吗？是的，我肯定我的Excel文件正在打开。此外，如果只有一个Excel文件正在打开（没有其他Excel文件），它仍然会出错，就像这样Hello Tim Williams，它仍然会出错，但我是用Thomas Inzina的源代码做的，不管怎样，非常感谢您的帮助：）当我运行宏it get error时，我想Workbooks.Open（ShortName）应该是一个完整路径，而不仅仅是文件名，所以，我将其更改为设置为getWorkbook=objExcel.Workbooks.Open（FULLNAME）。它运行良好，但似乎是您重新打开了此文件，因为当此文件与其他几个excel文件一起打开时，当我运行宏时，它会重新打开此文件并说“Book2.xlsm已打开，重新打开将导致放弃您所做的任何更改。是否要重新打开Book2.slsm”。我不想重新打开并收到此消息。如果没有此消息，我如何运行宏Hello Thomas Inzina，很抱歉，我已经打开了。只需在“Set getWorkbook=objExcel.Workbooks.Open（ShortName）”行中将ShortName更改为FULLNAME即可“而且跑得很好。非常感谢您的尝试help@Bruce别难过！我想了一会儿，我快疯了。我几乎有一本同名的工作簿。当我在测试的时候，我可以发誓有一个数字列表，然后它们就消失了。原来使用

ShortName

会导致我文档中的工作簿打开…哈哈。是的，使用ShortName lead打开它，它应该改为“全名”，我看到你编辑了你的问题，看起来很棒，再次感谢你的帮助：谢谢你接受我的答案。这是一个有趣的问题：）@ThomasInzina你有没有试一下？是的，我有。由于某些原因，错误时的

继续下一步

将无法逃脱错误9 ActiveX组件无法创建由错误的

getObject

调用引发的对象。我确信这在我的计算机上是一个错误的配置。除此之外，小故障，你的代码工作得非常好！！太好了。@ThomasInzina感谢您的测试，如果您要修复它，请告诉我（我希望在将它完全应用到其他项目之前要小心），您的代码工作得非常出色。这是我的机器。解决方法实际上是因为我无法逃避由

IsWorkBookOpen

引发的错误。我重写后，一切都像梦一样顺利。你可以考虑把你的<代码> ISWorkBooGuo.<代码>与我的：通过测试Excel用于工作簿的临时文件是否存在，我可以将

IsWorkBookOpen

的代码减少到4行，并且不会抛出任何错误。我创建了一个类来包装您的代码：。我还通过将一些代码提取到单独的方法中添加了一些功能

getOpenApplications

返回所有打开的Excel应用程序和从文件路径提取文件名的

getShortName

的集合。

Option Explicit

Private Declare Function FindWindowEx Lib "User32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long

Private Declare Function IIDFromString Lib "ole32" _
(ByVal lpsz As Long, ByRef lpiid As GUID) As Long

Private Declare Function AccessibleObjectFromWindow Lib "oleacc" _
(ByVal hWnd As Long, ByVal dwId As Long, ByRef riid As GUID, _
ByRef ppvObject As Object) As Long

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

Private Const RETURN_OK As Long = &H0
Private Const IID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}"
Private Const OBJID_NATIVEOM As Long = &HFFFFFFF0

Sub ComplexTest()

    Dim hWndXL As Long
    Dim oXLApp As Object
    Dim oWB As Object         
    Dim objExcel As Object
    Dim WB As Object
    Dim WS As Object
    Dim FullFileName    As String
    Dim CleanFileName   As String

    FullFileName = "C:\Users\sang\Desktop\Book2.xlsm"
    CleanFileName = Right(FullFileName, Len(FullFileName) - InStrRev(FullFileName, "\"))

    ' check if the Excel's file name is already open
    If IsWorkBookOpen(FullFileName) Then                                        
         ' first Excel Window
        hWndXL = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)             
         ' got one Excel instance open ?
        Do While hWndXL > 0

             ' Get a reference to current excel instance
            If GetReferenceToXLApp(hWndXL, oXLApp) Then                     
                 ' loop through workbooks
                For Each oWB In oXLApp.Workbooks
                    If oWB.Name = CleanFileName Then
                        Set WB = oWB
                    End If
                Next
            End If

             ' Find the next Excel Window
            hWndXL = FindWindowEx(0, hWndXL, "XLMAIN", vbNullString)
        Loop
    Else
        Set objExcel = CreateObject("Excel.Application")
        objExcel.Visible = True
        Set WB = objExcel.Workbooks.Open(FullFileName) 'open file
    End If

    Set WS = WB.Worksheets("Sheet1")
    WS.Range("A1").Value = "haha" 'set value for cell

End Sub

 ' This section of code was taken from Ozgrid
 ' link: http://www.ozgrid.com/forum/showthread.php?t=182853
 '
 ' The Function Returns a reference to a specific instance of Excel.
 ' The Instance is defined by the Handle (hWndXL) passed by the calling procedure

Function GetReferenceToXLApp(hWndXL As Long, oXLApp As Object) As Boolean

    Dim hWinDesk As Long
    Dim hWin7 As Long
    Dim obj As Object
    Dim iID As GUID

     ' Rather than explaining, go read
     ' http://msdn.microsoft.com/en-us/library/windows/desktop/ms687262(v=vs.85).aspx
    Call IIDFromString(StrPtr(IID_IDispatch), iID)

     ' We have the XL App (Class name XLMAIN)
     ' This window has a child called 'XLDESK' (which I presume to mean 'XL desktop')
     ' XLDesk is the container for all XL child windows....
    hWinDesk = FindWindowEx(hWndXL, 0&, "XLDESK", vbNullString)

     ' EXCEL7 is the class name for a Workbook window (and probably others, as well)
     ' This is used to check there is actually a workbook open in this instance.
    hWin7 = FindWindowEx(hWinDesk, 0&, "EXCEL7", vbNullString)

     ' Deep API... read up on it if interested.
     ' http://msdn.microsoft.com/en-us/library/windows/desktop/dd317978(v=vs.85).aspx
    If AccessibleObjectFromWindow(hWin7, OBJID_NATIVEOM, iID, obj) = RETURN_OK Then
        Set oXLApp = obj.Application
        GetReferenceToXLApp = True
    End If

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