Option Explicit
'+++*****************************************************+++
' 他ブックを開くサンプルコード
'+++*****************************************************+++
Sub SampleOpenBook()
Dim FileFullPath As String
Dim FileName As String
Dim FileBook As Workbook
Dim wb As Workbook
Dim IsOpen As Boolean
With ThisWorkbook.Worksheets("他ブックを開く")
FileFullPath = .Range("B5").Value
FileFullPath = Replace(FileFullPath, "/", "\")
FileName = Mid(FileFullPath, InStrRev(FileFullPath, "\") + 1)
End With
'作業中のPCで開いているかどうか
'開かれているファイルかどうか確認
IsOpen = False
For Each wb In Workbooks
'対象ファイルと同名のファイルが開かれている
If wb.Name = FileName Then
'対象ファイルそのものの場合
If wb.FullName = FileFullPath Then
IsOpen = True
Set FileBook = wb
Exit For
'対象ファイルそのものではない場合
Else
'同名ファイルは保存せず閉じる
wb.Close
End If
End If
Next wb
'【比較ファイル①】のシートを【比較結果】ファイルにコピー
'読み取り、リンク更新なしで開く
If IsOpen = False Then
Set FileBook = Workbooks.Open(FileName:=FileFullPath, _
ReadOnly:=True, UpdateLinks:=0)
End If
'====================================================
' 入力チェック
'====================================================
'ステータスバーに状況表示
Call showStatus("入力チェック中")
'空白、存在チェック
errMsg = "" '初期If format
'~~~
'~~~
SampleOpenBook_Exit:
'エラーを無視
On Error Resume Next
Call ReSetObject
Call Updating
'エラー制御を戻す
On Error GoTo 0
Exit Sub
SampleOpenBook_Err:
Bln_Err = True
MsgBox "実行時エラー:" & Err.Nuer & "" & _
Err.Description & vbCr & _
"処理を終了します。", vbExclamation, ErrProsName
Err.Clear 'エラー情報クリア
On Error GoTo 0
Exit Sub
InputCheck_Err:
'入力エラー時
If errMsg <> "" Then
MsgBox errMsg & vbCr & _
"処理を終了します。", vbExclamation, "入力エラー"
Err.Clear 'エラー情報クリア
GoTo SampleOpenBook_Exit
End If
End Sub
コメント