へたくそVBA
--モジュール1--
Sub フォルダ取得()
setei = Worksheets("書き出し結果").Range("E2").Value
setei2 = Worksheets("書き出し結果").Range("B2").Value
If setei <> 1 And setei <> 2 And setei <> 3 And setei <> 4 And setei <> 5 Then
MsgBox ("5階層までしかとれません。E2行目を見直してください")
Exit Sub
ElseIf setei2 = "" Then
MsgBox ("検索対象のフォルダを指定してください。B2行目に入力してください")
Exit Sub
End If
'データ削除
Dim x As Long
x = Rows.Count
Worksheets("data").Rows("5" & ":" & x).Clear
Worksheets("書き出し結果").Range("A5", "E" & x).Clear
'処理シート定義
Worksheets("data").Activate
Dim F1 As String
Dim i As Long
'階層の転記
i = 5
F1 = Dir(Cells(2, 2), vbDirectory)
Do While F1 <> ""
Cells(i, 1) = "1階層目"
Cells(i, 2) = F1
Cells(i, 3) = Cells(2, 2) & Cells(i, 2) & "\"
i = i + 1
F1 = Dir()
Loop
'セル削除（"."と".."）
For i = i To 5 Step -1
If Cells(i, 2).Value = "." Or Cells(i, 2).Value = ".." Then
Range(Cells(i, 1), Cells(i, 3)).Delete Shift:=xlUp
End If
Next
'リスト化
i1 = Worksheets("data").Cells(Rows.Count, 3).End(xlUp).Row
Worksheets("data").Range(Cells(5, 1), Cells(i1, 3)).Copy
Worksheets("書き出し結果").Range("A5").PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
'2～5階層取得
setei = Worksheets("書き出し結果").Range("E2").Value
Select Case setei
Case 2
Call フォルダ取得2層目
Case 3
Call フォルダ取得2層目
Call フォルダ取得3層目
Case 4
Call フォルダ取得2層目
Call フォルダ取得3層目
Call フォルダ取得4層目
Case 5
Call フォルダ取得2層目
Call フォルダ取得3層目
Call フォルダ取得4層目
Call フォルダ取得5層目
End Select
'処理シート変更
Worksheets("書き出し結果").Activate
Application.CutCopyMode = False 'コピーモード解除
'最後の\マーク削除
For l = 5 To Cells(Rows.Count, 3).End(xlUp).Row
Dim Str As String
Str = Cells(l, 3).Value
Cells(l, 3) = Left(Str, Len(Str) - 1)
Next
'タイムスタンプ
Range("D5", "D" & Cells(Rows.Count, 3).End(xlUp).Row) = Format(Now(), "yyyymmdd hhmm")
Range("A5").Select
End Sub
Sub フォルダ取得2層目()
Dim F2 As String
Dim j As Long
'階層の転記
i = 5
j = 5 + i - 5
For i = 5 To Cells(Rows.Count, 3).End(xlUp).Row
F2 = Dir(Cells(i, 3), vbDirectory)
Do While F2 <> ""
Cells(j, 4) = "2階層目"
Cells(j, 5) = F2
Cells(j, 6) = Cells(i, 3) & Cells(j, 5) & "\"
j = j + 1
F2 = Dir()
Loop 'jに+1して戻る
Next 'iに+1して戻る
'セル削除（"."と".."）
For j = j To 5 Step -1
If Cells(j, 5).Value = "." Or Cells(j, 5).Value = ".." Then
Range(Cells(j, 4), Cells(j, 6)).Delete Shift:=xlUp
End If
Next
'リスト化
i2 = Worksheets("data").Cells(Rows.Count, 6).End(xlUp).Row
k = Worksheets("書き出し結果").Cells(Rows.Count, 1).End(xlUp).Row + 1
Worksheets("data").Range(Cells(5, 4), Cells(i2, 6)).Copy
Worksheets("書き出し結果").Range("A" & k).PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
End Sub
Sub フォルダ取得3層目()
Dim F3 As String '変更箇所
Dim i As Long
Dim j As Long
'階層の転記
i = 5
j = 5 + i - 5
For i = 5 To Cells(Rows.Count, 6).End(xlUp).Row '変更箇所
F3 = Dir(Cells(i, 6), vbDirectory) '変更箇所
Do While F3 <> "" '変更箇所
Cells(j, 7) = "3階層目" '変更箇所
Cells(j, 8) = F3 '変更箇所
Cells(j, 9) = Cells(i, 6) & Cells(j, 8) & "\" '変更箇所
j = j + 1
F3 = Dir() '変更箇所
Loop 'jに+1して戻る
Next 'iに+1して戻る
'セル削除（"."と".."）
For j = j To 5 Step -1
If Cells(j, 8).Value = "." Or Cells(j, 8).Value = ".." Then '変更箇所
Range(Cells(j, 7), Cells(j, 9)).Delete Shift:=xlUp
End If
Next
'リスト化
i3 = Worksheets("data").Cells(Rows.Count, 9).End(xlUp).Row
k = Worksheets("書き出し結果").Cells(Rows.Count, 1).End(xlUp).Row + 1
Worksheets("data").Range(Cells(5, 7), Cells(i3, 9)).Copy
Worksheets("書き出し結果").Range("A" & k).PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
End Sub
Sub フォルダ取得4層目()
Dim F4 As String '変更箇所
Dim i As Long
Dim j As Long
'階層の転記
i = 5
j = 5 + i - 5
For i = 5 To Cells(Rows.Count, 9).End(xlUp).Row '変更箇所
F4 = Dir(Cells(i, 9), vbDirectory) '変更箇所
Do While F4 <> "" '変更箇所
Cells(j, 10) = "4階層目" '変更箇所
Cells(j, 11) = F4 '変更箇所
Cells(j, 12) = Cells(i, 9) & Cells(j, 11) & "\" '変更箇所
j = j + 1
F4 = Dir() '変更箇所
Loop 'jに+1して戻る
Next 'iに+1して戻る
'セル削除（"."と".."）
For j = j To 5 Step -1
If Cells(j, 11).Value = "." Or Cells(j, 11).Value = ".." Then '変更箇所
Range(Cells(j, 10), Cells(j, 12)).Delete Shift:=xlUp
End If
Next
'リスト化
i4 = Worksheets("data").Cells(Rows.Count, 12).End(xlUp).Row
k = Worksheets("書き出し結果").Cells(Rows.Count, 1).End(xlUp).Row + 1
Worksheets("data").Range(Cells(5, 10), Cells(i4, 12)).Copy
Worksheets("書き出し結果").Range("A" & k).PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
End Sub
Sub フォルダ取得5層目()
Dim F5 As String '変更箇所
Dim i As Long
Dim j As Long
'階層の転記
i = 5
j = 5 + i - 5
For i = 5 To Cells(Rows.Count, 12).End(xlUp).Row '変更箇所
F5 = Dir(Cells(i, 12), vbDirectory) '変更箇所
Do While F5 <> "" '変更箇所
Cells(j, 13) = "5階層目" '変更箇所
Cells(j, 14) = F5 '変更箇所
Cells(j, 15) = Cells(i, 12) & Cells(j, 14) & "\" '変更箇所
j = j + 1
F5 = Dir() '変更箇所
Loop 'jに+1して戻る
Next 'iに+1して戻る
'セル削除（"."と".."）
For j = j To 5 Step -1
If Cells(j, 14).Value = "." Or Cells(j, 14).Value = ".." Then '変更箇所
Range(Cells(j, 13), Cells(j, 15)).Delete Shift:=xlUp
End If
Next
'リスト化 変更必要
i5 = Worksheets("data").Cells(Rows.Count, 15).End(xlUp).Row
k = Worksheets("書き出し結果").Cells(Rows.Count, 1).End(xlUp).Row + 1
Worksheets("data").Range(Cells(5, 13), Cells(i5, 15)).Copy
Worksheets("書き出し結果").Range("A" & k).PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
End Sub
--モジュール2--
Sub 最新版と前回の差分確認()
'処理シート変更
Worksheets("書き出し結果").Activate
'前回分の確認結果（K）と色を消す
Cells.Interior.ColorIndex = 0
Range("B2", "C3").Interior.ColorIndex = 6
Range("E2").Interior.ColorIndex = 6
x = Rows.Count
Worksheets("書き出し結果").Range("K5", "K" & x).Clear
Dim myRange As Range
Dim myObj As Range
Dim keyWord As String
'E行に前回との差分あるかどうか書き出し
x = Cells(Rows.Count, 9).End(xlUp).Row
Set myRange = Range("I5", "I" & x)
'書き出し処理
For y = 5 To Cells(Rows.Count, 3).End(xlUp).Row
keyWord = Cells(y, 3).Value
Set myObj = myRange.Find(keyWord, LookAt:=xlWhole)
If myObj Is Nothing Then
Cells(y, 5) = "前回はなかったフォルダ"
Range(Cells(y, 1), Cells(y, 5)).Interior.ColorIndex = 6 ' 黄色
Else
Cells(y, 5) = myObj.Row & "行目"
End If
Next
'K行に最新分との差分あるかどうか書き出し
x = Cells(Rows.Count, 3).End(xlUp).Row
Set myRange = Range("C5", "C" & x)
'書き出し処理
For y = 5 To Cells(Rows.Count, 9).End(xlUp).Row
keyWord = Cells(y, 9).Value
Set myObj = myRange.Find(keyWord, LookAt:=xlWhole)
If myObj Is Nothing Then
Cells(y, 11) = "最新では消えているフォルダ"
Range(Cells(y, 7), Cells(y, 11)).Interior.ColorIndex = 6 ' 黄色
Else
Cells(y, 11) = myObj.Row & "行目"
End If
Next
End Sub