『リストは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
おしえていただいたコードでは、同名が3つ以上あっても
マークされるのは2つだけですよね。
同名があれば全てマークしたいのです。
調べて(ネットのコードの丸写し)以下となりました。
これで問題無いかは検証不足ですが3つまではマークされています。
(丸写しなので中身は、よく分からず利用しています。)
' 同名ファイルのチェック (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.