実行にあたっては下図のような表をあらかじめ作成しており、
かつフォルダは既に存在するものとする。
'フォルダは既に存在していると仮定する
'→存在しない場合は最深の階層から右へ三つのセルへエラーを表記する
Dim FolPath As String
Dim c As Long
Dim i As Long '処理を行っている階層の位置
Dim x As Long
Const goA As String = "A4" 'ディレクトリの最上層が書かれたセル位置
Const InGyo As Long = 4 '処理を始める行（二回目以降の処理は五行目から行う）
Sub 一括でフォルダを開く()
Dim R As Long
Dim myLink() As String '出力したことのあるｱﾄﾞﾚｽを格納する
ReDim Preserve myLink(0)
Dim co As Long
Dim n As Long '処理を行っているフォルダ
'二回目（5行目）以降で使用
'～子ディレクトリがない→ループから抜ける
'1回目のfalse ： 親ディレクトリの空白取得中
'true ： 空白ではない
'2回目のfalse ： 再度空白になった→ループから抜ける
Dim chF As Boolean
R = Range(goA).CurrentRegion.Rows.Count 'ディレクトリの最大数
c = Range(goA).CurrentRegion.Columns.Count '階層の深さ
'～～～4行目のディレクトリを構築する
n = InGyo '行を取得
'-1:パスを取得する
'一旦、FolPathを空白にする
FolPath = ""
x = n
For i = 1 To c '列を取得
Call GetFolPath
Next i
'-2:ファイルを開く
Call OpenFolPath
' '～～～5行目以降の処理を行う
For n = InGyo + 1 To 3 + R
'フラグを初期値にする
chF = False
'一旦、FolPathを空白にする
FolPath = ""
'浅い階層から深い階層へアドレスを読み進める
For i = 1 To c
'-0：変数ｘ = FolPathへ代入するｱﾄﾞﾚｽ（列数）
x = n '
If Cells(n, i).Value = "" Then
'空白の場合・・・
'1：chFがtrue→次の行に移動
If chF = True Then
Exit For
End If
'2:chFがfalse→上の列を読み込む(最大InGyo-1行目まで）
Do While Cells(x, i).Value = ""
If x = InGyo - 1 Then
'読み込み始めの行InGyoよりも上の行になったら処理を中止する
Exit Do
Else
x = x - 1
End If
Loop
ElseIf Cells(n, i).Value <> "" Then
'空白でない場合はその値をFolPathへ
chF = True
End If
'-1:パスを取得する
Call GetFolPath
Next i
'ファイルを開く
Call OpenFolPath
Next n
MsgBox "処理が完了しました"
End Sub
Private Sub GetFolPath()
If FolPath = "" Then
'一番上の階層
FolPath = Cells(x, i).Value
ElseIf Cells(x, i).Value <> "" Then
FolPath = FolPath & "\" & Cells(x, i).Value
End If
End Sub
Private Sub OpenFolPath()
Dim WSH As Object
'-2:FolPathが存在するか？
If Dir(FolPath, vbDirectory) = "" Then
'フォルダが存在しない
'→エラー表記を行う
Cells(x, c + 3).Value = "ファイルが存在しません"
Else
'フォルダが存在する
'→フォルダを開く
Set WSH = CreateObject("Wscript.Shell")
WSH.Run FolPath, 2
Set WSH = Nothing
End If
End Sub