『リストはB列に作成してソートして同名がある場合はA列に◯を付ける』（JIM'S）
お世話になります。
希望は、EXCELのVBAでドライブを複数指定してその中に存在するファイル名のリストを作成、
（但し、階層の深いディレクトリにも対応するようにしたい）
リストはB列に作成してソートして同名がある場合はA列に◯を付けるです。
コードを書き始めましたが
For Each subfolder IN folder.SubFolders で「書き込みできません。（実行エラー 70）」が出ました。
ローカルウインドウで調べたら : Path : "L:\$RECYCLE.BIN\-----" とゴミ箱？ホルダーを示していました。
ゴミ箱は、削除して何もない状態にしましたが同じエラーが出ます。
エラー防止の対策を教えて下さい。
他に留意すべき点があればお願いします。
Sub ファイルリスト作成()
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim drivePaths As Variant
drivePaths = Array("L:\", "G:\") ' 複数のドライブパスを指定
Dim i As Integer
i = 1 ' リストの開始行
Dim drive As Variant
For Each drive In drivePaths
Call フォルダ内のファイルをリストアップ(fso.GetFolder(drive), i)
Next drive
' B列を基準にソート
Range("B1:B" & i - 1).Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlYes
' 同名ファイルのチェック
Dim j As Integer
For j = 2 To i - 1
If Cells(j, 2).Value = Cells(j + 1, 2).Value Then
Cells(j, 1).Value = "◯"
End If
Next j
End Sub
Sub フォルダ内のファイルをリストアップ(folder As Object, ByRef i As Integer)
Dim subfolder As Object
For Each subfolder In folder.SubFolders
Call フォルダ内のファイルをリストアップ(subfolder, i)
Next subfolder
Dim file As Object
For Each file In folder.Files
Cells(i, 2).Value = file.Name
i = i + 1
Next file
End Sub
＜ 使用 Excel：Excel2021、使用 OS：Windows11 ＞
subfolderの名前に"RECYCLE"が含めれているかどうかをInStr関数で調べたらどうですか? 含まれていたら、それ以下の処理は行わない、と。 （xyz） 2024/04/25(木) 20:04:14
うまく処理出来るコードを考えられなかったので
On Error Resume Nextでエラーがあっても続けるようにしました。
とりあえずほぼ満足出来る結果を得たのですが
最後の「同名ファイルのチェック」で同じファイルが多数ある場合は
全てに◯を付ける方法はどうすればいいですか ？
Sub ファイルリスト作成()
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim drivePaths As Variant
drivePaths = Array("L:\", "G:\") ' 複数のドライブパスを指定
Columns("A:B").ClearContents
Dim i As Integer
i = 1 ' リストの開始行
Dim drive As Variant
For Each drive In drivePaths
Call フォルダ内のファイルをリストアップ(fso.GetFolder(drive), i)
Next drive
'不用ファイル削除(ゴミ箱相当)
Dim Lc As Long
Lc = Cells(Rows.Count, 2).End(xlUp).Row
Dim ii As Long
For ii = Lc To 1 Step -1
If Left(Cells(ii, 2).Value, 1) = "$" Then
Rows(ii).Delete
End If
Next ii
'使用行の再チェック（不用ファイル削除のため）
Lc = Cells(Rows.Count, 2).End(xlUp).Row
' B列を基準にソート
Range("B1:C" & Lc).Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlNo
' 同名ファイルのチェック
Dim iii As Long
For iii = 2 To Lc
If Range("B" & iii).Value = Range("B" & iii - 1).Value Then
Range("A" & iii).Value = "◯"
End If
Next iii
End Sub
Sub フォルダ内のファイルをリストアップ(folder As Object, ByRef i As Integer)
Dim subfolder As Object
For Each subfolder In folder.SubFolders
On Error Resume Next
Call フォルダ内のファイルをリストアップ(subfolder, i)
On Error GoTo 0
Next subfolder
Dim file As Object
For Each file In folder.Files
Cells(i, 2).Value = file.Name
Cells(i, 3).Value = file.Path
i = i + 1
Next file
End Sub
（JIM'S） 2024/04/25(木) 20:08:30
コードを最初のままUPしました。
以下に訂正します。
Sub ファイルリスト作成()
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim drivePaths As Variant
drivePaths = Array("L:\", "G:\") ' 複数のドライブパスを指定
Columns("A:B").ClearContents
Dim i As Integer
i = 1 ' リストの開始行
Dim drive As Variant
For Each drive In drivePaths
Call フォルダ内のファイルをリストアップ(fso.GetFolder(drive), i)
Next drive
'不用ファイル削除(ゴミ箱相当)
Dim Lc As Long
Lc = Cells(Rows.Count, 2).End(xlUp).Row
Dim ii As Long
For ii = Lc To 1 Step -1
If Left(Cells(ii, 2).Value, 1) = "$" Then
Rows(ii).Delete
End If
Next ii
'使用行の再チェック（不用ファイル削除のため）
Lc = Cells(Rows.Count, 2).End(xlUp).Row
' B列を基準にソート
Range("B1:C" & Lc).Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlNo
' 同名ファイルのチェック
Dim iii As Long
For iii = 2 To Lc
If Range("B" & iii).Value = Range("B" & iii - 1).Value Then
Range("A" & iii).Value = "◯"
End If
Next iii
End Sub
Sub フォルダ内のファイルをリストアップ(folder As Object, ByRef i As Integer)
Dim subfolder As Object
For Each subfolder In folder.SubFolders
On Error Resume Next
Call フォルダ内のファイルをリストアップ(subfolder, i)
On Error GoTo 0
Next subfolder
Dim file As Object
For Each file In folder.Files
Cells(i, 2).Value = file.Name
Cells(i, 3).Value = file.Path
i = i + 1
Next file
End Sub
（JIM'S） 2024/04/25(木) 21:30:10
こういうことですか？
For iii = 2 To Lc
If Range("B" & iii).Value = Range("B" & iii - 1).Value Then
Range("A" & iii - 1).Value = "◯" ' ■追加
Range("A" & iii).Value = "◯"
End If
Next iii
（xyz） 2024/04/26(金) 09:59:58
おしえていただいたコードでは、同名が３つ以上あっても
マークされるのは２つだけですよね。
同名があれば全てマークしたいのです。
調べて（ネットのコードの丸写し）以下となりました。
これで問題無いかは検証不足ですが３つまではマークされています。
（丸写しなので中身は、よく分からず利用しています。）
' 同名ファイルのチェック (A列にマーク＝◯を付加）
Dim rng As Range
Dim cell As Range
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Set rng = Range("B1:B" & Range("B" & Rows.Count).End(xlUp).Row)
For Each cell In rng
If Not dict.Exists(cell.Value) Then
dict.Add cell.Value, cell.Row
Else
Range("A" & cell.Row).Value = "○"
dict(cell.Value) = dict(cell.Value) & "," & cell.Row
End If
（JIM'S） 2024/04/26(金) 11:26:15
（xyz） 2024/04/26(金) 13:53:33
A列 B列
2行 d.xlsm
3 d.xlsm
4 d.xlsm
という例で考えると、今のコードは
B3 と B2 を比較して A3に〇
B4 と B3 を比較して A4に〇
となるだけです。A2は空白のまま。
修正案では、 B3 と B2 を比較して A2とA3にそれぞれ〇 B4 と B3 を比較して A3とA4にそれぞれ〇 となって、3つすべてに〇がつくと思いますが、そういう話じゃないんですか? 4つ以上連続していても同じです。すべての行で、前行と比較するわけですから。 （xyz） 2024/04/26(金) 14:10:18
返事はないのでしょうか。
dictionaryを使った貴兄の案も漏れがでてきます。 理論上、一回のループ処理では絶対に実現できません。 初回登場の時点で、後続に同じものがでてくるかは予見できないので、 その時点でA列に〇を入力できません。
dictionaryを使うなら、こんな感じにすればよいでしょう。
Dim rng As Range
Dim r As Range
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Set rng = Range("B1:B" & Range("B" & Rows.Count).End(xlUp).Row)
For Each r In rng
dic(r.Value) = dic(r.Value) + 1
Next
For Each r In rng
If dic(r.Value) > 1 Then r.Offset(0, -1) = "〇"
Next
（xyz） 2024/04/29(月) 08:16:42
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.