参照したいファイル名(*.xls)を開くと、このファイル名がThisWorkbook.Sheets("初期値").Cells(2, 2)に書き込まれます。またフォルダー名がThisWorkbook.Sheets("初期値").Cells(3, 2)に書き込まれます。

次回からはこのフォルダーからファイル選択画面が開きます。

このためファイルを一度開くと次回から開くのが楽になります。

 

下記のコードは、顧客リストを開く例です。

 

Dim wb As Workbook
Dim blnFlag As Boolean
Dim shSyokiti As Object
Dim PathDB As String
Dim tempDir As String
Dim flag As Boolean

 

Set shSyokiti = ThisWorkbook.Sheets("初期値")

Application.StatusBar = "必要なファイルを開きます"

For Each wb In Workbooks
    If wb.Name = Trim(shSyokiti.Cells(2, 2))  Then
        flag = True
    End If
Next wb

 

If flag = True Then
    'MsgBox "顧客リストはすでに開いています。", vbInformation
Else
    'カレントフォルダーを初期値指定コーナーに記録されているフォルダーに移す
    On Error Resume Next
    PathDB = shSyokiti.Cells(3, 2)
   
    'GetOpenFilenameのためにカレントフォルダーを出力データベースファイルの存在するフォルダーに移す
    'http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110_140.html
    If PathDB <> "" And Left(PathDB, 2) <> "\\" Then    'ネットワークで無いフォルダーにカレントを移す
        ChDrive PathDB
        ChDir PathDB
   
    ElseIf Len(PathDB) >= 5 And Left(PathDB, 2) = "\\" Then    'ネットワークにカレントフォルダーを移す
            CreateObject("WScript.Shell").CurrentDirectory = PathDB
    End If
    On Error GoTo 0
   
    MsgBox "顧客リストをこれから開きます", vbInformation
    '顧客リストのファイルを指定する
    tempDir = Application.GetOpenFilename("顧客リスト(*.xls),*.xls", Title:="顧客リストのファイルを指定")
   
    If tempDir = "False" Then
        MsgBox "ファイルが指定されませんでしたので終了します。"
        End
    End If
   
    '顧客リストのファイルを開く
    Application.Workbooks.Open (tempDir)
    PathDB = ActiveWorkbook.Path
    
    '顧客リストのファイルのPathを初期値指定コーナーに記録
    '次回、楽に開くため
    shSyokiti.Cells(3, 2) = PathDB
    shSyokiti.Cells(2, 2) = ActiveWorkbook.name
End If

 

'カレントフォルダーを本ファイルのある場所に移す
ChDrive ThisWorkbook.Path
ChDir ThisWorkbook.Path