フリーページ
全て
| カテゴリ未分類
| ミッションステートメントを作ろう
| 内緒で会社を作るわたしに50の質問
| ダイエット
| 神田語録
| 肥満・肥満児
| しょうが
| 花粉
| 脳力トレーニング
| 楽天 ベストバイ ワーストバイ
2024年02月12日
カテゴリ： カテゴリ未分類
Sub FindTopLevelFoldersImproved()
Dim wsLog As Worksheet, wsSheet2 As Worksheet
Dim lastRow As Long, lastCol As Long, i As Long, j As Long
Dim dictFolders As Object, listTopFolders As Object
Dim userId As Variant, folderPath As Variant, checkPath As Variant
Dim isTopFolder As Boolean
Dim row As Long
Set wsLog = ThisWorkbook.Sheets("log")
Set wsSheet2 = ThisWorkbook.Sheets("Sheet2")
Set dictFolders = CreateObject("Scripting.Dictionary")
lastRow = wsLog.Cells(wsLog.Rows.Count, "A").End(xlUp).Row
lastCol = wsLog.Cells(1, wsLog.Columns.Count).End(xlToLeft).Column
' 全てのフォルダパスを収集
For i = 2 To lastRow
For j = 4 To lastCol ' D列から始まるアクセス権者ID
If wsLog.Cells(i, j).Value = "○" Then
folderPath = wsLog.Cells(i, 1).Value
userId = wsLog.Cells(1, j).Value
If Not dictFolders.Exists(userId) Then
Set dictFolders(userId) = CreateObject("Scripting.Dictionary")
End If
dictFolders(userId)(folderPath) = True
End If
Next j
Next i
' Sheet2をクリア
wsSheet2.Cells.ClearContents
wsSheet2.Cells(1, 1).Value = "権利者"
wsSheet2.Cells(1, 2).Value = "最上層フォルダ"
row = 2
' 最上層フォルダを特定
For Each userId In dictFolders.Keys
Set listTopFolders = CreateObject("Scripting.Dictionary")
isTopFolder = True
For Each checkPath In dictFolders(userId).Keys
If folderPath <> checkPath And InStr(1, folderPath & "\", checkPath & "\") > 0 Then
isTopFolder = False
Exit For
End If
Next checkPath
' フォルダが最上層であればリストに追加
If isTopFolder Then
If Not listTopFolders.Exists(folderPath) Then
listTopFolders.Add folderPath, True
End If
End If
Next folderPath
' 特定された最上層フォルダをSheet2に出力
For Each folderPath In listTopFolders.Keys
wsSheet2.Cells(row, 1).Value = userId
wsSheet2.Cells(row, 2).Value = folderPath
row = row + 1
Next folderPath
Next userId
MsgBox "最上層フォルダの特定が完了しました。", vbInformation
End Sub
お気に入りの記事を「いいね！」で応援しよう
【毎日開催】
15記事にいいね！で1ポイント
PR
キーワードサーチ
▼キーワード検索
Helio Japan
みなさん、花粉症対策ってどうしてます??
毎日がエヴリディ！
oyazy44さん
ドラマチックな映画… groomixさん
スッポンの達人 弥右ヱ門さん
アメリカ奮闘記 System of a Downさん
吉川裕一のオースト… 和歌山の風達人 ヒロさんさん
ドラマチックな映画… groomixさん
スッポンの達人 弥右ヱ門さん
アメリカ奮闘記 System of a Downさん
吉川裕一のオースト… 和歌山の風達人 ヒロさんさん
コメント新着
© Rakuten Group, Inc.
