フリーページ
全て
| カテゴリ未分類
| ミッションステートメントを作ろう
| 内緒で会社を作るわたしに50の質問
| ダイエット
| 神田語録
| 肥満・肥満児
| しょうが
| 花粉
| 脳力トレーニング
| 楽天 ベストバイ ワーストバイ
2025年02月09日
カテゴリ： カテゴリ未分類
Sub FindTopLevelAccessFolder()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
' F列をクリア
ws.Range("F2:F" & lastRow).ClearContents
Dim i As Long
Dim currentRoot As String
Dim minAccessLevel As Long
' 最初のパスをルートとして設定
currentRoot = GetRootPath(ws.Cells(2, "B").Value)
minAccessLevel = 999
' まず、各ルートパスごとの最小アクセスレベルを見つける
For i = 2 To lastRow
Dim thisRoot As String
thisRoot = GetRootPath(ws.Cells(i, "B").Value)
' 新しいルートパスの開始
If thisRoot <> currentRoot Then
currentRoot = thisRoot
minAccessLevel = 999
End If
' アクセス権のある最小レベルを更新
If ws.Cells(i, "E").Value = "○" Then
minAccessLevel = WorksheetFunction.Min(minAccessLevel, ws.Cells(i, "D").Value)
End If
' このパスの最小レベルと同じレベルで、かつ上位にアクセス権がない場合のみ○を付ける
If ws.Cells(i, "D").Value = minAccessLevel And ws.Cells(i, "E").Value = "○" Then
If Not HasUpperAccess(ws, i) Then
ws.Cells(i, "F").Value = "○"
End If
End If
Next i
End Sub
Private Function GetRootPath(fullPath As String) As String
Dim parts() As String
parts = Split(fullPath, "\")
If UBound(parts) >= 3 Then
GetRootPath = parts(0) & "\" & parts(1) & "\" & parts(2) & "\" & parts(3)
Else
GetRootPath = fullPath
End If
End Function
Private Function HasUpperAccess(ws As Worksheet, currentRow As Long) As Boolean
Dim currentPath As String
Dim currentLevel As Long
currentPath = ws.Cells(currentRow, "B").Value
currentLevel = ws.Cells(currentRow, "D").Value
' 現在の行より上の行をチェック
Dim i As Long
For i = currentRow - 1 To 2 Step -1
' 同じルートパスで、より上位の階層にアクセス権がある場合
If InStr(currentPath, ws.Cells(i, "B").Value) = 1 And _
ws.Cells(i, "D").Value < currentLevel And _
ws.Cells(i, "E").Value = "○" Then
HasUpperAccess = True
Exit Function
End If
Next i
HasUpperAccess = False
End Function
お気に入りの記事を「いいね！」で応援しよう
【毎日開催】
15記事にいいね！で1ポイント
PR
キーワードサーチ
▼キーワード検索
Helio Japan
みなさん、花粉症対策ってどうしてます??
毎日がエヴリディ！
oyazy44さん
ドラマチックな映画… groomixさん
スッポンの達人 弥右ヱ門さん
アメリカ奮闘記 System of a Downさん
吉川裕一のオースト… 和歌山の風達人 ヒロさんさん
ドラマチックな映画… groomixさん
スッポンの達人 弥右ヱ門さん
アメリカ奮闘記 System of a Downさん
吉川裕一のオースト… 和歌山の風達人 ヒロさんさん
コメント新着
© Rakuten Group, Inc.
