[Exxcel VBA]ファイルを開く処理のエラー回避方法

今回は、VBAにてExcel,CSV,Textファイルを開く際にエラーが出る事象を回避するプログラムを組みました。

不備や漏れがある可能性があるため、コメント頂けると幸いです。

■関数

・ユーザー定義　Open_ExcelCSVTextFile(OpenFilePathName)

OpenFilePathName　ファイル名を指定します。

戻り値 True/False（ファイルを開く、またはすでに開いてるときにTrueを返します。）

■機能

ファイル名を指定しない場合は処理を中止。

対象のファイル名が存在しない場合は処理を中止。

拡張子にて、.xls?,csv,txt以外を指定している場合は処理を中止。

すでに開いているファイルを指定した場合は以下の処理を実施。

・メッセージにて選択（Yes,No,Cancel）を要求。

・Yesを選択する場合は、開いているファイルを上書保存後、フラグを真に変更し処理を終了。

・Noを選択する場合は、開いているファイルには何もせず、フラグを真に変更し処理を終了。

・Cancelを選択する場合は、なにもせずに処理を終了。

開いているファイルとは別に、別フォルダでファイル名が一致している場合は以下の処理を実施。

・Yesを選択する場合は、名前の変更を行う。(最終的にファイルを開くとフラグが真になる)

・Noを選択する場合は、なにもせずに処理を終了。

Option Explicit

'開いた場合、または、既に開いていた場合はTrueを返す
Function Open_ExcelCSVTextFile(ByRef OpenFilePathName As String) As Boolean

    Dim OpenFileName    As String           'OpenFilePathNameのファイル名
    Dim OpenFilePath    As String           'OpenFilePathNameのパス
    Dim NewFileName     As String           'ファイル名変更用
    Dim MsgData         As String           'メッセージ文
    Dim WorkBookNum     As Integer          '開いているファイルナンバー
    Dim FSO             As Object           'FileSystemObject
    
    Const MsgTitle      As String = "ファイルを開く"
    Const MsgTitle2     As String = "ファイル名変更"
    
    Open_ExcelCSVTextFile = False
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    OpenFileName = FSO.GetFileName(OpenFilePathName)
    OpenFilePath = Replace(OpenFilePathName, OpenFileName, "")
    
    Select Case True
    
        Case OpenFilePathName = Empty
            
            MsgBox "ファイル名が設定されていません。ファイルを開く処理を中止します。", vbCritical, MsgTitle
            Exit Function
 
        Case FSO.FileExists(OpenFilePathName) = False
    
            MsgBox "対象のファイルが存在しません。ファイルを開く処理を中止します。", vbCritical, MsgTitle
            Exit Function
    
        Case Not (FSO.GetExtensionName(OpenFilePathName) Like "xls?" Or _
                    FSO.GetExtensionName(OpenFilePathName) = "xls" Or _
                    FSO.GetExtensionName(OpenFilePathName) = "txt" Or _
                    FSO.GetExtensionName(OpenFilePathName) = "csv")
            
            MsgBox "対象外の拡張子が設定されています。ファイルを開く処理を中止します。", vbCritical, MsgTitle
            Exit Function
        
    End Select

    '開いているファイルの数だけ繰り返し
    For WorkBookNum = 1 To Workbooks.Count
        
        '既に開いているファイルと開こうとするパスファイル名が一致する場合
        If OpenFilePathName = Workbooks(WorkBookNum).FullName Then
                
            MsgData = OpenFilePathName & " は既に開かれています。" & vbCrLf & _
                    "ファイルを保存し、後続処理を実施しますか？" & vbCrLf & vbCrLf & _
                    "（※後続処理終了後、ファイルは保存され閉じられます。）" & vbCrLf & vbCrLf & _
                    "「はい」：" & OpenFileName & " を保存し後続処理を実施" & vbCrLf & vbCrLf & _
                    "「いいえ」：" & OpenFileName & " を保存せずに後続処理を実施" & vbCrLf & vbCrLf & _
                    "「キャンセル」：" & OpenFileName & " を保存せずに処理終了"

            'メッセージを出力、選択によって処理を変える
            Select Case MsgBox(MsgData, vbExclamation + vbYesNoCancel, MsgTitle)
                
                Case vbYes
                    Workbooks(OpenFileName).Save
                    Open_ExcelCSVTextFile = True: Exit Function
                    
                Case vbNo
                    Open_ExcelCSVTextFile = True: Exit Function
                    
                Case vbCancel: Exit Function
                
            End Select

        '一致しない場合
        ElseIf OpenFileName = Workbooks(WorkBookNum).Name Then
        
            MsgData = OpenFileName & " は別のフォルダから同ファイル名で既に開かれています。" & vbCrLf & _
                    "ファイルの名前を変更し、ファイルを開きますか？" & vbCrLf & vbCrLf & _
                    "「はい」：" & OpenFileName & " のファイル名を変更しファイルを開く" & vbCrLf & vbCrLf & _
                    "「いいえ」：" & OpenFileName & " のファイル名を変更せず処理終了"
                    
            'メッセージを出力、選択によって処理を変える
            If MsgBox(MsgData, vbExclamation + vbYesNo, MsgTitle) = vbNo Then Exit Function
                
            Do
            
                '新ファイル名を設定
                MsgData = "ファイル名を変更します。 ※ \,/,:,*,?,"""",<,>,| は使用できません。" & vbCrLf & _
                            "「キャンセル」 ： ファイル名を変更せず処理終了"
                            
                NewFileName = Application.InputBox(MsgData, MsgTitle2, OpenFileName, , , , , 2)
                
                Select Case True
                
                    '「キャンセル」
                    Case NewFileName = "False": Exit Function
                        
                    Case NewFileName = OpenFileName
                    
                        MsgData = "同じファイル名が設定されました。再編集しますか？" & vbCrLf & vbCrLf & _
                                    "「はい」 ： 再編集" & vbCrLf & _
                                    "「いいえ」 ： 再編集せず処理終了"
                                    
                        If MsgBox(MsgData, vbExclamation + vbYesNo, MsgTitle2) = vbNo Then Exit Function

                    Case NewFileName Like "*[\,/,:,*,?,"""",<,>,|]*"
                    
                        MsgData = "ファイル名に使用できない文字が含まれています。再編集しますか？" & vbCrLf & vbCrLf & _
                                    "「はい」 ： 再編集" & vbCrLf & _
                                    "「いいえ」 ： 再編集せず処理終了"
                                    
                        If MsgBox(MsgData, vbExclamation + vbYesNo, MsgTitle2) = vbNo Then Exit Function
                
                    Case NewFileName = Empty
                    
                        MsgData = "ファイル名が空白です。再編集しますか？" & vbCrLf & vbCrLf & _
                                    "「はい」 ： 再編集" & vbCrLf & _
                                    "「いいえ」 ： 再編集せず処理終了"
                    
                        If MsgBox(MsgData, vbExclamation + vbYesNo, MsgTitle2) = vbNo Then Exit Function
                        
                    Case Not (FSO.GetExtensionName(NewFileName) Like "xls?" Or _
                            FSO.GetExtensionName(NewFileName) = "xls" Or _
                            FSO.GetExtensionName(NewFileName) = "txt" Or _
                            FSO.GetExtensionName(NewFileName) = "csv")
                            
                        MsgData = "対象外の拡張子が設定されています。再編集しますか？" & vbCrLf & vbCrLf & _
                            "「はい」 ： 再編集" & vbCrLf & _
                            "「いいえ」 ： 再編集せず処理終了"
                    
                        If MsgBox(MsgData, vbExclamation + vbYesNo, MsgTitle2) = vbNo Then Exit Function
                        
                    Case Not FSO.GetExtensionName(OpenFileName) = FSO.GetExtensionName(NewFileName)
                    
                        MsgData = "拡張子が変更されています。再編集しますか？" & vbCrLf & vbCrLf & _
                            "「はい」 ： 再編集" & vbCrLf & _
                            "「いいえ」 ： 再編集せず処理終了"
                    
                        If MsgBox(MsgData, vbExclamation + vbYesNo, MsgTitle2) = vbNo Then Exit Function
                    
                    Case Else
                
                        MsgData = "下記ファイル名に変更しますか？" & vbCrLf & vbCrLf & _
                                    OpenFilePath & NewFileName & vbCrLf & vbCrLf & _
                                    "「はい」 ： 変更し後続作業を実施" & vbCrLf & _
                                    "「いいえ」 ： 再編集" & vbCrLf & _
                                    "「キャンセル」 ： 変更せず処理終了"

                        Select Case MsgBox(MsgData, vbInformation + vbYesNoCancel, MsgTitle2)
                        
                            Case vbYes
                                
                                FileCopy OpenFilePathName, OpenFilePath & NewFileName
                                Kill OpenFilePathName
                                OpenFilePathName = OpenFilePath & NewFileName

                                Open_ExcelCSVTextFile = True
                                Exit For
                                
                            Case vbCancel: Exit Function
                            
                        End Select
                        
                End Select
                
            Loop
                
        End If
            
    Next
    
    'ファイルを開く
    Workbooks.Open OpenFilePathName, False, False, , , , True
    Open_ExcelCSVTextFile = True
    
End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

Option Explicit

'開いた場合、または、既に開いていた場合はTrueを返す

Function Open_ExcelCSVTextFile(ByRef OpenFilePathName As String) As Boolean

Dim OpenFileName As String 'OpenFilePathNameのファイル名

Dim OpenFilePath As String 'OpenFilePathNameのパス

Dim NewFileName As String 'ファイル名変更用

Dim MsgData As String 'メッセージ文

Dim WorkBookNum As Integer '開いているファイルナンバー

Dim FSO As Object 'FileSystemObject

Const MsgTitle As String = "ファイルを開く"

Const MsgTitle2 As String = "ファイル名変更"

Open_ExcelCSVTextFile = False

Set FSO = CreateObject("Scripting.FileSystemObject")

OpenFileName = FSO.GetFileName(OpenFilePathName)

OpenFilePath = Replace(OpenFilePathName, OpenFileName, "")

Select Case True

Case OpenFilePathName = Empty

MsgBox "ファイル名が設定されていません。ファイルを開く処理を中止します。", vbCritical, MsgTitle

Exit Function

Case FSO.FileExists(OpenFilePathName) = False

MsgBox "対象のファイルが存在しません。ファイルを開く処理を中止します。", vbCritical, MsgTitle

Exit Function

Case Not (FSO.GetExtensionName(OpenFilePathName) Like "xls?" Or _

FSO.GetExtensionName(OpenFilePathName) = "xls" Or _

FSO.GetExtensionName(OpenFilePathName) = "txt" Or _

FSO.GetExtensionName(OpenFilePathName) = "csv")

MsgBox "対象外の拡張子が設定されています。ファイルを開く処理を中止します。", vbCritical, MsgTitle

Exit Function

End Select

'開いているファイルの数だけ繰り返し

For WorkBookNum = 1 To Workbooks.Count

'既に開いているファイルと開こうとするパスファイル名が一致する場合

If OpenFilePathName = Workbooks(WorkBookNum).FullName Then

MsgData = OpenFilePathName & " は既に開かれています。" & vbCrLf & _

"ファイルを保存し、後続処理を実施しますか？" & vbCrLf & vbCrLf & _

"（※後続処理終了後、ファイルは保存され閉じられます。）" & vbCrLf & vbCrLf & _

"「はい」：" & OpenFileName & " を保存し後続処理を実施" & vbCrLf & vbCrLf & _

"「いいえ」：" & OpenFileName & " を保存せずに後続処理を実施" & vbCrLf & vbCrLf & _

"「キャンセル」：" & OpenFileName & " を保存せずに処理終了"

'メッセージを出力、選択によって処理を変える

Select Case MsgBox(MsgData, vbExclamation + vbYesNoCancel, MsgTitle)

Case vbYes

Workbooks(OpenFileName).Save

Open_ExcelCSVTextFile = True: Exit Function

Case vbNo

Open_ExcelCSVTextFile = True: Exit Function

Case vbCancel: Exit Function

End Select

'一致しない場合

ElseIf OpenFileName = Workbooks(WorkBookNum).Name Then

MsgData = OpenFileName & " は別のフォルダから同ファイル名で既に開かれています。" & vbCrLf & _

"ファイルの名前を変更し、ファイルを開きますか？" & vbCrLf & vbCrLf & _

"「はい」：" & OpenFileName & " のファイル名を変更しファイルを開く" & vbCrLf & vbCrLf & _

"「いいえ」：" & OpenFileName & " のファイル名を変更せず処理終了"

'メッセージを出力、選択によって処理を変える

If MsgBox(MsgData, vbExclamation + vbYesNo, MsgTitle) = vbNo Then Exit Function

'新ファイル名を設定

MsgData = "ファイル名を変更します。 ※ \,/,:,*,?,"""",<,>,| は使用できません。" & vbCrLf & _

"「キャンセル」：ファイル名を変更せず処理終了"

NewFileName = Application.InputBox(MsgData, MsgTitle2, OpenFileName, , , , , 2)

Select Case True

'「キャンセル」

Case NewFileName = "False": Exit Function

Case NewFileName = OpenFileName

MsgData = "同じファイル名が設定されました。再編集しますか？" & vbCrLf & vbCrLf & _

"「はい」：再編集" & vbCrLf & _

"「いいえ」：再編集せず処理終了"

If MsgBox(MsgData, vbExclamation + vbYesNo, MsgTitle2) = vbNo Then Exit Function

Case NewFileName Like "*[\,/,:,*,?,"""",<,>,|]*"

MsgData = "ファイル名に使用できない文字が含まれています。再編集しますか？" & vbCrLf & vbCrLf & _

"「はい」：再編集" & vbCrLf & _

"「いいえ」：再編集せず処理終了"

If MsgBox(MsgData, vbExclamation + vbYesNo, MsgTitle2) = vbNo Then Exit Function

Case NewFileName = Empty

MsgData = "ファイル名が空白です。再編集しますか？" & vbCrLf & vbCrLf & _

"「はい」：再編集" & vbCrLf & _

"「いいえ」：再編集せず処理終了"

If MsgBox(MsgData, vbExclamation + vbYesNo, MsgTitle2) = vbNo Then Exit Function

Case Not (FSO.GetExtensionName(NewFileName) Like "xls?" Or _

FSO.GetExtensionName(NewFileName) = "xls" Or _

FSO.GetExtensionName(NewFileName) = "txt" Or _

FSO.GetExtensionName(NewFileName) = "csv")

MsgData = "対象外の拡張子が設定されています。再編集しますか？" & vbCrLf & vbCrLf & _

"「はい」：再編集" & vbCrLf & _

"「いいえ」：再編集せず処理終了"

If MsgBox(MsgData, vbExclamation + vbYesNo, MsgTitle2) = vbNo Then Exit Function

Case Not FSO.GetExtensionName(OpenFileName) = FSO.GetExtensionName(NewFileName)

MsgData = "拡張子が変更されています。再編集しますか？" & vbCrLf & vbCrLf & _

"「はい」：再編集" & vbCrLf & _

"「いいえ」：再編集せず処理終了"

If MsgBox(MsgData, vbExclamation + vbYesNo, MsgTitle2) = vbNo Then Exit Function

Case Else

MsgData = "下記ファイル名に変更しますか？" & vbCrLf & vbCrLf & _

OpenFilePath & NewFileName & vbCrLf & vbCrLf & _

"「はい」：変更し後続作業を実施" & vbCrLf & _

"「いいえ」：再編集" & vbCrLf & _

"「キャンセル」：変更せず処理終了"

Select Case MsgBox(MsgData, vbInformation + vbYesNoCancel, MsgTitle2)

Case vbYes

FileCopy OpenFilePathName, OpenFilePath & NewFileName

Kill OpenFilePathName

OpenFilePathName = OpenFilePath & NewFileName

Open_ExcelCSVTextFile = True

Exit For

Case vbCancel: Exit Function

End Select

Loop

End If

'ファイルを開く

Workbooks.Open OpenFilePathName, False, False, , , , True

Open_ExcelCSVTextFile = True

End Function

---コメント---