5

以下のコードに問題があります。

Private Sub Worksheet_BeforeDoubleClick(ByVal...
Application.ScreenUpdating = False
Set wbks = Workbooks.Open("\\whatever\whatever.xlsx")           
wbks.Sheets("Control").Activate
ActiveSheet.Range("A3").Select 
Application.ScreenUpdating = True
...

ご覧のとおり、特定のセルをダブルクリックするたびにワークブックが開きます。問題は次のとおりです。2 回目にダブルクリックすると、迷惑なメッセージが表示されます。

「'Filename.xlsx' は既に開いています。再度開くと、行った変更が破棄されます...」

(変更が行われていないため) このメッセージをオフにするにはどうすればよいですか? また、可能であれば、対象のワークブックを「再度開く」のではなく、ダブルクリックするたびに「更新」するようにするにはどうすればよいですか?

4

1 に答える 1

7

関数を使用して、既に開いているかどうかを確認できます。

Function WorkbookIsOpen(wb_name As String) As Boolean

On Error Resume Next
WorkbookIsOpen = CBool(Len(Workbooks(wb_name).Name) > 0)
End Function

次に、プロシージャで次のように呼び出します。

Private Sub Worksheet_BeforeDoubleClick(ByVal...
Application.ScreenUpdating = False
If WorkbookIsOpen("whatever.xlsx") then
    Set wbks = Workbooks("whatever.xlsx")
Else
    Set wbks = Workbooks.Open("\\whatever\whatever.xlsx")
End If      
wbks.Sheets("Control").Activate
ActiveSheet.Range("A3").Select 
Application.ScreenUpdating = True

編集:本当に夢中になりたい場合は、ファイルが存在するかどうかを確認し、存在Nothingしない場合は返すこの関数を使用できます。そうでない場合は、Workbook上記のロジックを少し拡張して を返します。

Function GetWorkbook(WbFullName As String) As Excel.Workbook

'checks whether workbook exists
'if no, returns nothing
'if yes and already open, returns wb
'if yes and not open, opens and returns workbook
Dim WbName As String

WbName = Mid(WbFullName, InStrRev(WbFullName, Application.PathSeparator) + 1)
If Not WorkbookIsOpen(WbName) Then
    If FileExists(WbFullName) Then
        Set GetWorkbook = Workbooks.Open(Filename:=WbFullName, UpdateLinks:=False, ReadOnly:=True)
    Else
        Set GetWorkbook = Nothing
    End If
Else
    Set GetWorkbook = Workbooks(WbName)
End If
End Function

WorkbookIsOpen上記の関数に加えて、次の関数を使用します。

Function FileExists(strFileName As String) As Boolean

If Dir(pathname:=strFileName, Attributes:=vbNormal) <> "" Then
    FileExists = True
End If
End Function

次のような手順でこれを使用できます。

Private Sub Worksheet_BeforeDoubleClick(ByVal...
Application.ScreenUpdating = False
Set wbks = GetWorkbook("\\whatever\whatever.xlsx")
If wbks is Nothing Then
    MsgBox "That's funny, it was just here"
    'exit sub gracefully
End If
wbks.Sheets("Control").Activate
ActiveSheet.Range("A3").Select 
Application.ScreenUpdating = True
于 2013-05-30T00:35:06.093 に答える