2018年10月24日水曜日

ワークブックを開く

エクセルのファイルを開く時に、ダイアログで直接指定して開くのであればダイアログの出し方だけを気にしておけばよいですが、セル等に保存されているファイルのフルパスを読んで開く場合はファイルの存在チェックなどが必要になります。
で、ダイアログの使い方の例と、ファイルのフルパスを指定してブックを開く関数です。

ダイアログ


まず、ダイアログの書き方です。

FileDialog(msoFileDialogOpen)

    Sub Bookを開く()
        With Application.FileDialog(msoFileDialogOpen)
            With .Filters
                .Clear
                .Add "Excelブック", "*.xls; *.xlsx; *.xlsm", 1
                .Add "すべてのファイル", "*.*", 2
            End With
            .InitialFileName = ThisWorkbook.FullName
            .Title = "ファイルを開く"
            If .Show = True Then
                .Execute
            Else
                ''キャンセルボタンが押された
            End If
        End With
    End Sub

FileDialog(msoFileDialogFilePicker)

    Sub 指定したファイルを配列にセット()
        Dim i           As Integer
        Dim arrFiles()  As String
    
        With Application.FileDialog(msoFileDialogFilePicker)
            .AllowMultiSelect = True
            With .Filters
                .Clear
                .Add "Excelブック", "*.xls; *.xlsx; *.xlsm", 1
                .Add "すべてのファイル", "*.*", 2
            End With
            .InitialFileName = ThisWorkbook.FullName
            If .Show = True Then
                For i = 1 To .SelectedItems.Count
                    ReDim Preserve arrFiles(1 To i)
                    arrFiles(i) = .SelectedItems(i)
                Next
            Else
                ''キャンセルボタンが押された
            End If
        End With
    End Sub

FileDialog(msoFileDialogFolderPicker)

    Sub フォルダの取得()
        Dim sPath As String
        
        With Application.FileDialog(msoFileDialogFolderPicker)
            .InitialFileName = ThisWorkbook.Path
            .Title = "フォルダの選択"
            If .Show = True Then
                sPath = .SelectedItems(1)
            Else
                ''キャンセルボタンが押された
            End If
        End With
    End Sub

GetOpenFilename:1ファイル

    Sub ファイル名を取得()
        Dim FileToOpen As Variant
        
        FileToOpen = Application.GetOpenFilename( _
                         "Excelブック(*.xls?), *.xls?,すべてのファイル(*.*),*.*", _
                         1, _
                         "ファイル名を取得")
        If FileToOpen = False Then Exit Sub
    End Sub

GetOpenFilename:複数ファイル名を取得

    Sub 複数ファイル名を取得()
        Dim FileToOpen  As Variant
        
        FileToOpen = Application.GetOpenFilename( _
                         "Excelブック(*.xls?),*.xls?,すべてのファイル(*.*),*.*", _
                         2, _
                         "ファイル名を取得", , True)
        If VarType(FileToOpen) = vbBoolean Then
            If FileToOpen = False Then Exit Sub
        Else
            ''FileToOpen(配列、インデックス:1ベース)でFullNameを取得できる
        End If
    End Sub

関数サンプル


ファイルのフルパスを渡して開いて、ワークブックオブジェクトを戻すようにしました。
    Sub OpenBookの呼び出し()
        Dim sfile
        Dim wb As Workbook
        On Error GoTo AbEnd
        sfile = "ファイルのフルパス"
        Set wb = OpenBook(sfile)
        Exit Sub
    AbEnd:
        MsgBox Err.Description
    End Sub
'========================================================================='
    Function OpenBook( _
        ByVal pBookFullNameToOpen As String _
    ) As Workbook
'========================================================================='
        
        Dim home As Workbook
        Dim ScrUpdStatus As Boolean
        Dim Buff As String
        Dim wb As Workbook
        
        ''初期化
        Set OpenBook = Nothing
        Set home = ActiveWorkbook
        ScrUpdStatus = Application.ScreenUpdating
    
        Buff = Dir(pBookFullNameToOpen)
        
        If Buff = "" Then
            Err.Raise 800, "OpenBook", "指定したBookはありません"
            Exit Function
        End If
        
        For Each wb In Workbooks
            If wb.Name = Buff Then
                Err.Raise 800, "OpenBook", "指定したBookは既に開いています"
                Exit Function
            End If
        Next wb
        
        Application.ScreenUpdating = False
            Workbooks.Open pBookFullNameToOpen
            Set OpenBook = ActiveWorkbook
            home.Activate
        Application.ScreenUpdating = ScrUpdStatus
        
    End Function

0 件のコメント:

コメントを投稿