パソコン

フリーページ

< 新しい記事

新着記事一覧(全200件)

過去の記事 >

2025年02月07日

テスト

カテゴリ：カテゴリ未分類

Sub ExtractFoldersToDelete()

Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim folderPath As String
Dim topFolderPath As String
Dim result As String
Dim currentLevel As Long
Dim previousLevel As Long

Set ws = ThisWorkbook.Sheets("Sheet1") ' "Sheet1"はデータが入力されているシート名

' 最終行を取得
lastRow = ws.Cells(Rows.Count, "B").End(xlUp).Row

' 結果を格納する変数を初期化
result = ""

' 2行目から最終行までループ
previousLevel = 1 ' 初期値を1に設定

For i = 2 To lastRow

' E列に"◯"が付いている場合
If ws.Cells(i, "E").Value = "◯" Then

folderPath = ws.Cells(i, "B").Value

' 最上位のフォルダパスを取得
topFolderPath = GetTopFolderPath(folderPath, currentLevel)

' 重複チェック
If Not IsDuplicate(result, topFolderPath) Then

' 結果文字列に追加 (改行付き)

End If

End If

previousLevel = currentLevel ' 前の階層数を更新

Next i

' 結果をメッセージボックスに表示
MsgBox result

End Sub

' 最上位のフォルダパスを取得する関数 (階層数を引数に追加)
Function GetTopFolderPath(folderPath As String, currentLevel As Long) As String

Dim parts() As String
parts = Split(folderPath, "\")

' 最上位のフォルダパスを組み立てる
If currentLevel > 1 Then
GetTopFolderPath = parts(1) & "\" & parts(2)
Else
GetTopFolderPath = folderPath ' 最上位フォルダの場合はそのまま
End If

End Function

' 重複チェック関数
Function IsDuplicate(result As String, folderPath As String) As Boolean

IsDuplicate = (InStr(1, result, folderPath) > 0)

End Function

お気に入りの記事を「いいね！」で応援しよう