Results of 1 - 1 of about 37667 for IF (0.007 sec.)
- [[20240208144349]]
- #score: 1591
- @digest: 0fbcf3213cde8b138c9b12eb534ea911
- @id: 96151
- @mdate: 2024-02-10T02:42:08Z
- @size: 36907
- @type: text/plain
- #keywords: fileattribute (159983), ofolder (148844), 増毛 (133102), folderpicker (118626), alldirectories (118093), inipath (110930), regpattern (109022), getfiles (77741), strarray (72185), regex (63422), ismissing (35584), optional (13959), 角ス (13088), folder (12675), ブフ (12660), サブ (12350), caption (12163), system (11912), lastrow (9965), 2024 (9377), ォル (8688), path (8476), hidden (7866), ルダ (7584), 出力 (7386), スペ (7124), 重複 (6844), ダ内 (6408), dic (6166), フォ (6097), object (6043), 半角 (6035)
- 『ファイルの削除』（増毛）
外付けHDDに最初が、「アルファベット3桁の(又は4桁)-3桁数字+半角スペース」で始まるファイルが多数存在します。 例えば、 「K:¥2002¥Fukuoka¥HNMU-156 更新資料(F_223).txt」 HDDを指定してHDD内のサブホルダーも対象に（多階層も対象に） EXCELでパス部を区別せずに「3桁(又は4桁)-3桁数字+半角スペース」で始まるファイル名のみををB列に、 C列にB列に対応するフルパス付きのファイル名を全て順番に全て書き出したいのですがVBAのコードを教えてほしい 出力結果 B: HNMU-156 更新資料(F_223).txt C: K:¥2002¥Fukuoka¥HNMU-156 更新資料(F_223).txt 最終的には、B列をソートした結果を元に不必要なファイルがあればA列にチェックマークを入れて ファイルを削除するようにコードを改造する予定です。 ＜ 使用 Excel:Excel2021、使用 OS:Windows11 ＞ ---- 小さく作って小さく実行してみたらいかがでしょう。 例えば、AAAというフォルダを作成し、適当に4つのぐらいのファイルを AAAフォルダに作成して、そのファイル名の一覧をA列に書き出してみる という感じです。 増毛様は、VBAで上記のことは可能ですか? （匿名） 2024/02/08(木) 15:22:03 ---- ＞VBAで上記のことは可能ですか? 最初から希望の処理は難しいのでネットを頼りに簡単なコードを作成しましたが HDD内のゴミ箱のファイルにも反応するし最後はエラーで止まってしまうしで挫折しました。 Option Explicit '変数の宣言 Dim fso As Object 'FileSystemObjectのオブジェクト Dim folder As Object 'Folderのオブジェクト Dim file As Object 'Fileのオブジェクト Dim ws As Worksheet '出力先のワークシート Dim row As Long '出力する行番号 Dim path As String '指定するフォルダのパス Sub OutputFileList() '出力先のワークシートを設定 Set ws = ThisWorkbook.Sheets("Sheet1") '出力する行番号を初期化 row = 1 '指定するフォルダのパスを入力 path = InputBox("フォルダのパスを入力してください。", "フォルダ選択") '入力がキャンセルされた場合は終了 If path = "" Then Exit Sub 'FileSystemObjectのオブジェクトを作成 Set fso = CreateObject("Scripting.FileSystemObject") '指定したフォルダのオブジェクトを取得 Set folder = fso.GetFolder(path) 'フォルダ内のファイルとサブフォルダを出力するサブルーチンを呼び出す Call OutputFilesAndFolders(folder) 'メッセージを表示 MsgBox "出力が完了しました。", vbInformation, "完了" End Sub 'フォルダ内のファイルとサブフォルダを出力するサブルーチン Sub OutputFilesAndFolders(folder As Object) 'フォルダ内のファイルを出力 For Each file In folder.Files 'ファイル名をB列に出力 ws.Cells(row, 2).Value = file.Name 'フルパスをC列に出力 ws.Cells(row, 3).Value = file.path '行番号をインクリメント row = row + 1 Next file 'フォルダ内のサブフォルダを出力 For Each folder In folder.SubFolders 'サブフォルダ名をB列に出力 ws.Cells(row, 2).Value = folder.Name 'フルパスをC列に出力 ws.Cells(row, 3).Value = folder.path '行番号をインクリメント row = row + 1 'サブフォルダ内のファイルとサブフォルダを再帰的に出力 Call OutputFilesAndFolders(folder) Next folder End Sub （増毛） 2024/02/08(木) 15:36:58 ---- コードはできていますね。 ということは、最初の質問の 「VBAのコードを教えてほしい」というのは何だったのでしょう。 ＞HDD内のゴミ箱のファイルにも反応するし最後はエラーで止まってしまうしで挫折しました。 最初からこの質問でよかった気がします。 ゴミ箱のファイルに反応するという表現ではなく ゴミ箱フォルダのファイルも出力してしまう ということですかね。それならば、ごみ箱フォルダ内は 出力しないようにしてあげればよいかと思います(IF文)。 コンピュータが出したエラーメッセージは? なんというエラーが出ているかが重要です。 （匿名） 2024/02/08(木) 16:12:48 ---- ＞ゴミ箱フォルダのファイルも出力してしまう はい、そのとうりです。 ＞なんというエラーが出ているかが重要です。 実行エラー 70 : 書き込みができません。 For Each file In folder.Files ＞「VBAのコードを教えてほしい」というのは何だったのでしょう。 最初は、質問にあるようなコードを目指しましたが 上手くいかないので簡単な現在のマクロで進めました。 （これで上手くできればその先に最初の質問のコードに進めるような気がしたので） （増毛） 2024/02/08(木) 16:37:44 ---- OutputFilesAndFoldersに on error resume nextを挿入では? （mm） 2024/02/08(木) 17:12:22 ---- ありがとうございます。 ＞on error resume nextを挿入では? エラーがなくなりました。 'フォルダ内のファイルとサブフォルダを出力するサブルーチン Sub OutputFilesAndFolders(folder As Object) On Error Resume Next B列見ると、1200行の内「System Volume Information」が500行以上ありました。 削除するのはマクロが終了後に別で処理できますがこれって正常なのでしょうか? （増毛） 2024/02/08(木) 17:31:03 ---- 書き忘れです。 On Error Resume Next の他に匿名さんのアドバイスでコードを修正しています。 '行番号をインクリメント row = row + 1 'サブフォルダ内のファイルとサブフォルダを再帰的に出力 If folder.Name <> "$RECYCLE.BIN" Then '←この行を追加 Call OutputFilesAndFolders(folder) End If Next folder （増毛） 2024/02/08(木) 18:30:23 ---- [[20230723134646]] 『階層フォルダー内のファイルの変名』（マートン） （こんな過去ログが） 2024/02/08(木) 19:03:33 ---- ちょっと、興味がでたので、FSOを使った再帰を書いてみました。 列挙体はリンク先の（´・ω・`）さんのを、拝借しました。 Transposeを使っているので、列挙数が2^16（=65536) を超える場合は、失敗します。 Private Enum FileAttribute Normal = 0 ReadOnly = 1 Hidden = 2 System = 4 Volume = 8 Directory = 16 Archive = 32 End Enum Private Function FolderPicker(Optional caption As Variant, Optional iniPath As Variant) As String With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False If IsMissing(caption) Then caption = "フォルダを選択" .Title = caption If Not IsMissing(iniPath) Then .InitialFileName = iniPath If .Show Then FolderPicker = .SelectedItems(1) End If End With End Function Private Sub GetFiles(ByVal path$, ByRef dic As Object, ByVal regPattern$, Optional ByVal AllDirectories As Boolean = False) If dic Is Nothing Then Set dic = CreateObject("Scripting.Dictionary") Static RegEx As Object If RegEx Is Nothing Then Set RegEx = CreateObject("VBScript.RegExp") RegEx.Pattern = regPattern Static FSO As Object If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject") Dim oFolder As Object, f As Object, flag As Boolean Set oFolder = FSO.GetFolder(path) If (Not oFolder.isRootFolder) And (oFolder.Attributes And (FileAttribute.System + FileAttribute.Hidden)) Then Exit Sub On Error Resume Next For Each f In oFolder.Files flag = False flag = RegEx.test(f.Name) If flag Then dic(f.path) = f.Name Next If AllDirectories Then For Each f In oFolder.SubFolders Call GetFiles(f.path, dic, regPattern, AllDirectories) Next End If End Sub Sub OutputFileList() Dim path$ '指定するフォルダのパスを入力 path = FolderPicker '入力がキャンセルされた場合は終了 If path = "" Then Exit Sub Dim dic As Object 'フォルダ内のファイルを出力するサブルーチンを呼び出す '3桁(又は4桁)-3桁数字+半角スペース」 Call GetFiles(path, dic, "^.{3,4}-¥d{3} .*$", True) '結果を出力 With Sheets("Sheet1") .Columns("B:C").Clear .Range("B1") = "FileName": .Range("C1") = "FullPath" If dic.Count > 0 And dic.Count < 2 ^ 16 Then .Range("B2").Resize(dic.Count) = Application.Transpose(dic.items) .Range("C2").Resize(dic.Count) = Application.Transpose(dic.Keys) End If End With 'メッセージを表示 MsgBox "出力が完了しました。", vbInformation, "完了" End Sub （まる2021） 2024/02/08(木) 20:42:33 ---- FSOを使って再帰するのは、速度的にも遅いし、スタック枯渇の恐れもあるし、 Shell廻りの処理はPowerShellを利用するのがお勧めです。 速度的にはWin32 APIを使えばもっと高速に取得できますが、マーシャリングの知識がないとお勧めできません。 というわけで、PowerShellを使った例も提示しておきます。 Private Function FolderPicker(Optional caption As Variant, Optional iniPath As Variant) As String With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False If IsMissing(caption) Then caption = "フォルダを選択" .Title = caption If Not IsMissing(iniPath) Then .InitialFileName = iniPath If .Show Then FolderPicker = .SelectedItems(1) End If End With End Function Sub GetFilesPowerShell() Dim psCmd$, path$ path = FolderPicker If path = "" Then Exit Sub psCmd = "Get-ChildItem -Path '<path>' -File -Recurse -ErrorAction SilentlyContinue|" & _ "? {$_.BaseName -match '^.{3,4}-¥d{3} .*$'} |" & _ "% {$_.Name + """"""`t"""""" + $_.FullName} |Set-Clipboard" psCmd = VBA.Replace(psCmd, "<path>", path) CreateObject("WScript.Shell").Run "powershell -ExecutionPolicy RemoteSigned -Command " & psCmd, 0, True With Sheets("Sheet1") .Columns("B:C").Clear On Error Resume Next ActiveSheet.Paste Destination:=.Range("B1") If Err.Number <> 0 Then MsgBox "ファイルが見つかりませんでした", vbCritical Else MsgBox "出力が完了しました。", vbInformation, "完了" End If On Error GoTo 0 End With End Sub （まる2021） 2024/02/08(木) 23:28:29 ---- まる2021さん、VBAをありがとうございます。 （「二頭追うものは一頭も得ず」なので手を広げたら先が見えなくなるので 過去ログの参照先の『階層フォルダー内のファイルの変名』はまだ見ていません。） powershell版では無い最初のコードを試用させていただきました。 結果は、 HDDの直下のフォルダーを指定した場合は上手く処理できましたが、 "フォルダを選択"でドライブレター（K:¥）を指定すると全くA,B列に書き込みがありません。 "フォルダを選択"でドライブレターを選択できるようには出来ないのでしょうか? 非表示のSYSTEMFOLDERやゴミ箱フォルダーの関係で無理なら 非表示でないHDDの直下のフォルダーを一つ選択して処理、 他のフォルダーを同様に処理して最後にそれぞれの結果を結合するようにします。 （増毛） 2024/02/09(金) 08:32:50 ---- え、ドライブ単位ですか。 GetFilesの↓を If oFolder.Attributes And (FileAttribute.System + FileAttribute.Hidden) Then Exit Sub リンク先のように If (Not oFolder.isRootFolder) And (oFolder.Attributes And (FileAttribute.System + FileAttribute.Hidden)) Then Exit Sub に変えて試してください。 3桁(又は4桁)-3桁数字+半角スペース」のファイル総数はどれくらいになるのでしょう? 前にも書きましたが、列挙数が2^16（=65536) を超える場合は、失敗します。 その場合は、1つずつセルに書き込んでいくことになります。 元を修正しときました。 2/9 9:48 （まる2021） 2024/02/09(金) 09:31:20 ---- まる2021さん、ドライブ単位の修正をありがとうございます。 上手く処理できました。 確認ですが、行ではなく列数ですか ? Transposeなので縦（行）を横（列）に変換と考えると 処理できるのは最大65536行までと言う事ですか ? 現在ファイル数が3000ほどなのでファイル数が65536を超える事は無いと思います。 ＞元を修正しときました。 2/9 9:48 現状でもファイル数が超える事が無いので 修正前のマクロ(重複ファイルのチェック)で良いと思いますが 9:48に修正されたとの事なので修正版に変更したいのですが これはどこにありますか ? ここのサイトの修正方法が理解できていないので 2024/02/08(木) 20:42:33 のコードは、9:48に修正されているのですか? 試しに、2024/02/08(木) 20:42:33 のコード中に「 Transpose」を検索してみましたがヒットしませんでした。 それと自分の利用しているマクロでも「 Transpose」を検索してもヒットしません。 （コードをコピペしたのは、9:48以前なので以前のコードだと思います） 以下は、私の少し追加があるマクロコードです。 （ソートがおかしいのか?重複していない部分も黄色で着色されます。） Private Enum FileAttribute Normal = 0 ReadOnly = 1 Hidden = 2 System = 4 Volume = 8 Directory = 16 Archive = 32 End Enum Sub 重複ファイルのチェック() Dim path$ '指定するフォルダのパスを入力 path = FolderPicker '入力がキャンセルされた場合は終了 If path = "" Then Exit Sub Dim dic As Object 'フォルダ内のファイルを出力するサブルーチンを呼び出す '3桁(又は4桁)-3桁数字+半角スペース」 Call GetFiles(path, dic, "^.{3,4}-¥d{3} .*$", True) '結果を出力 Dim ws As Worksheet Set ws = Sheets("DATA") With ws .Columns("A:C").Clear Range("A1") = "Mark": .Range("B1") = "FileName": .Range("C1") = "FullPath" If dic.Count > 0 And dic.Count < 2 ^ 16 Then .Range("B2").Resize(dic.Count) = Application.Transpose(dic.Items) .Range("C2").Resize(dic.Count) = Application.Transpose(dic.Keys) End If End With 'B列ソート------------------------------- Dim rng As Range 'データの範囲のオブジェクト Dim cell As Range 'セルのオブジェクト Dim lastRow As Long '最終行の番号 '最終行の番号を取得 lastRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).row 'データの範囲を設定 Set rng = ws.Range("B1:C" & lastRow) 'B列をキーにして昇順にソート 'Header引数にxlYesを指定することで、先頭行をタイトルとして除外しています。 rng.Sort Key1:=rng.Columns(1), Order1:=xlAscending, Header:=xlYes 'B列で各行の文字列中で先頭から半角スペースまでの文字列を対象に重複があるかチェックして -------- '重複がある場合は、B列を黄色で塗りつぶす ------------------------------------------------------- 'B列のデータを配列に格納 Dim data As Variant data = Range("B1:B" & lastRow).Value '先頭から半角スペースまでの文字列を格納する配列を宣言 Dim strArray() As String ReDim strArray(1 To UBound(data)) '配列の各要素に対して、先頭から半角スペースまでの文字列を取り出す Dim i As Long Dim str As String For i = 1 To UBound(data) 'セルの値を文字列に変換 str = CStr(data(i, 1)) '半角スペースの位置を検索 Dim spacePos As Long spacePos = InStr(str, " ") '半角スペースがある場合は、先頭から半角スペースまでの文字列を取り出す If spacePos > 0 Then str = Left(str, spacePos - 1) End If '取り出した文字列を別の配列に格納 strArray(i) = str Next i '現在の条件付き書式をクリア Range("B1:C" & lastRow).FormatConditions.Delete '別の配列の要素を重複チェックする Dim j As Long Dim k As Long For j = 1 To UBound(strArray) - 1 For k = j + 1 To UBound(strArray) '同じ文字列がある場合は、対応する行のB列のセルの背景色を黄色にする If strArray(j) = strArray(k) Then Range("B" & j).Interior.color = vbYellow Range("B" & k).Interior.color = vbYellow End If Next k Next j '----------------------------------- 'メッセージを表示 MsgBox "出力が完了しました。", vbInformation, "完了" Set ws = Nothing End Sub Private Function FolderPicker(Optional caption As Variant, Optional iniPath As Variant) As String With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False If IsMissing(caption) Then caption = "フォルダを選択" .Title = caption If Not IsMissing(iniPath) Then .InitialFileName = iniPath If .Show Then FolderPicker = .SelectedItems(1) End If End With End Function Private Sub GetFiles(ByVal path$, ByRef dic As Object, ByVal regPattern$, Optional ByVal AllDirectories As Boolean = False) If dic Is Nothing Then Set dic = CreateObject("Scripting.Dictionary") Static RegEx As Object If RegEx Is Nothing Then Set RegEx = CreateObject("VBScript.RegExp") RegEx.pattern = regPattern Static FSO As Object If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject") Dim oFolder As Object, f As Object, flag As Boolean Set oFolder = FSO.GetFolder(path) 'ドライブ指定の場合 If (Not oFolder.IsRootFolder) And (oFolder.Attributes And (FileAttribute.System + FileAttribute.Hidden)) Then Exit Sub 'フォルダー指定の場合 'If oFolder.Attributes And (FileAttribute.System + FileAttribute.Hidden) Then Exit Sub On Error Resume Next For Each f In oFolder.Files flag = False flag = RegEx.Test(f.Name) If flag Then dic(f.path) = f.Name Next If AllDirectories Then For Each f In oFolder.SubFolders Call GetFiles(f.path, dic, regPattern, AllDirectories) Next End If End Sub （増毛） 2024/02/09(金) 11:40:45 ---- >現在ファイル数が3000ほどなのでファイル数が65536を超える事は無いと思います。 なら、問題ないです。ファイル数（=行数）の事です。 修正したのは、（まる2021） 2024/02/08(木) 20:42:33 の投稿です。ついでに （まる2021） 2024/02/08(木) 23:28:29も修正しました。増毛さんの最終コードに反映されているので問題ありません。 >B列で各行の文字列中で先頭から半角スペースまでの文字列を対象に重複があるかチェックして こういうのは、最初の質問で書いてもらいたいです。GetFiles内でせっかくチェックしてるのに... 昼休み内に間に合えば、修正版をアップします。ダメなら夜になります。 （まる2021） 2024/02/09(金) 12:09:16 ---- ついでに、聞きますがSheets("DATA")のD列以降は自由に使っていいですか? （まる2021） 2024/02/09(金) 12:17:47 ---- ＞増毛さんの最終コードに反映されているので問題ありません。 確認いただき感謝します。 ＞こういうのは、最初の質問で書いてもらいたいです 最初の質問で「3桁(又は4桁)-3桁数字+半角スペース」と記載していましたが 改めてソートして色分けされたB列をみると、3桁(又は4桁)-3桁数字にこだわる必要は無く 「B列で各行の文字列中で先頭から半角スペースまでの文字列」で良いのだと気が付きました。 気が付くのが遅くて要らない事を考慮するような結果でご面倒をおかけして申し訳ないです。 ＞聞きますがSheets("DATA")のD列以降は自由に使っていいですか? はい、自由に利用されても問題ありません。 （増毛） 2024/02/09(金) 13:15:08 ---- こんな感じになりました。 D,E列を重複チェック用に使っています。条件付き書式でE列の値を使って黄色に塗り潰してます。 Transposeを使うのを止めたので「2^16」の制限はなくなりました。 Private Enum FileAttribute Normal = 0 ReadOnly = 1 Hidden = 2 System = 4 Volume = 8 Directory = 16 Archive = 32 End Enum Private Function FolderPicker(Optional caption As Variant, Optional iniPath As Variant) As String With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False If IsMissing(caption) Then caption = "フォルダを選択" .Title = caption If Not IsMissing(iniPath) Then .InitialFileName = iniPath If .Show Then FolderPicker = .SelectedItems(1) End If End With End Function Private Sub GetFiles(ByVal path$, ByRef dic As Object, ByVal regPattern$, Optional ByVal AllDirectories As Boolean = False) If dic Is Nothing Then Set dic = CreateObject("Scripting.Dictionary") Static RegEx As Object If RegEx Is Nothing Then Set RegEx = CreateObject("VBScript.RegExp") RegEx.Pattern = regPattern Static FSO As Object If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject") Dim oFolder As Object, f As Object, mc Set oFolder = FSO.GetFolder(path) If (Not oFolder.isRootFolder) And (oFolder.Attributes And (FileAttribute.System + FileAttribute.Hidden)) Then Exit Sub On Error Resume Next For Each f In oFolder.Files Set mc = Nothing Set mc = RegEx.Execute(f.Name) If Not mc Is Nothing Then If mc.Count > 0 Then dic(f.path) = Array(f.Name, mc(0).SubMatches(0)) End If Next If AllDirectories Then For Each f In oFolder.SubFolders Call GetFiles(f.path, dic, regPattern, AllDirectories) Next End If End Sub Sub 重複ファイルのチェック() Dim path$ '指定するフォルダのパスを入力 path = FolderPicker '入力がキャンセルされた場合は終了 If path = "" Then Exit Sub Dim dic As Object 'フォルダ内のファイルを出力するサブルーチンを呼び出す '3桁(又は4桁)-3桁数字+半角スペース」 Call GetFiles(path, dic, "^(.{3,4}-¥d{3}) .*$", True) '結果を出力 Dim ws As Worksheet, k, i&, rng As Range Set ws = Sheets("DATA") With ws .Columns("A:E").Clear Range("A1") = "Mark": .Range("B1") = "FileName": .Range("C1") = "FullPath" .Range("D1") = "3桁(又は4桁)-3桁数字": .Range("E1") = "重複数" Application.ScreenUpdating = False If dic.Count > 0 Then For Each k In dic .Range("B2").Offset(i).Value = dic(k)(0) .Range("C2").Offset(i).Value = k .Range("D2").Offset(i).Value = dic(k)(1) i = i + 1 Next .Range("E2").Formula2 = "=COUNTIF(" & .Range("D2").Resize(dic.Count).Address & _ "," & .Range("D2").Resize(dic.Count).Address & ")" .Range("E2").Resize(dic.Count).Value = .Range("E2").Resize(dic.Count).Value 'B列ソート------------------------------- 'データの範囲を設定 Set rng = ws.Range("B1:E1").Resize(dic.Count + 1) 'B列をキーにして昇順にソート 'Header引数にxlYesを指定することで、先頭行をタイトルとして除外しています。 rng.Sort Key1:=rng.Columns(1), Order1:=xlAscending, Header:=xlYes 'B列で各行の文字列中で先頭から半角スペースまでの文字列を対象に重複があるかチェックして -------- '重複がある場合は、B列を黄色で塗りつぶす ------------------------------------------------------- 'B列に条件付き書式設定 With .Range("B2").Resize(dic.Count).FormatConditions.Add(xlExpression, Formula1:="=RC[3]>1") .Interior.Color = vbYellow End With End If End With '----------------------------------- Application.ScreenUpdating = True 'メッセージを表示 MsgBox "出力が完了しました。", vbInformation, "完了" End Sub （まる2021） 2024/02/09(金) 18:45:02 ---- まる2021さん、参考コードありがとうございます。 私のコードも残すようにして作成されているので判りやすく参考になります。 私の現在のマクロに利用できないか考えてみます。 その後、私の方でもマクロコードを修正しています。 （増毛） 2024/02/09(金) 11:40:45 で 「ソートがおかしいのか?重複していない部分も黄色で着色されます。」 と書き込みしましたが 原因は、文字列の最初に半角スペースがあると重複と判断されると判明しました。 これを明確に判るように緑色でセルを着色するのを追加しています。 又、別シート（重複）に重複分だけを抜き出して不必要なファイルがあればA列にチェックマークを入れて ファイルを削除するようにしました。 とここまでは、 ほぼマクロコードは出来上がったと思いましたが 重複が無い場合に備えてエラー対策としてIF分で判断を追加したら思わぬ事が発生しました。 「 'B列で黄色に着色されている行をシート「重複」に書き出す」で 重複が無い場合は、lastRowが0なのでIf lastRow > 1 で良いはずですが なぜだか、何も無いのにlastRowが1となるのです。 （それで 苦肉の策で、If lastRow >= 2 Then としています。） 「'シート「重複」のB列の各行の先頭の文字が空白（全角スペース、半角スペース）であればセルを緑色に着色」 でも同じ理由で If lastRow <= 1 としています。 何が原因でlastRowが0にならないのか原因が判るでしょうか? Option Explicit Private Enum FileAttribute Normal = 0 ReadOnly = 1 Hidden = 2 System = 4 Volume = 8 Directory = 16 Archive = 32 End Enum Sub 重複ファイルのチェック() Dim path$ '指定するフォルダのパスを入力 path = FolderPicker '入力がキャンセルされた場合は終了 If path = "" Then Exit Sub Dim dic As Object 'フォルダ内のファイルを出力するサブルーチンを呼び出す '3桁(又は4桁)-3桁数字+半角スペース」 Call GetFiles(path, dic, "^.{3,4}-¥d{3} .*$", True) '結果を出力 Dim ws As Worksheet Set ws = Sheets("DATA") With ws .Columns("A:C").Clear Range("A1") = "Mark": .Range("B1") = "FileName": .Range("C1") = "FullPath" If dic.Count > 0 And dic.Count < 2 ^ 16 Then .Range("B2").Resize(dic.Count) = Application.Transpose(dic.Items) .Range("C2").Resize(dic.Count) = Application.Transpose(dic.Keys) End If End With 'B列ソート------------------------------- Dim rng As Range 'データの範囲のオブジェクト Dim cell As Range 'セルのオブジェクト Dim lastRow As Long '最終行の番号 '最終行の番号を取得 lastRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row 'データの範囲を設定 Set rng = ws.Range("B1:C" & lastRow) 'B列をキーにして昇順にソート 'Header引数にxlYesを指定することで、先頭行をタイトルとして除外しています。 rng.Sort Key1:=rng.Columns(1), Order1:=xlAscending, Header:=xlYes 'B列で各行の文字列中で先頭から半角スペースまでの文字列を対象に重複があるかチェックして -------- '重複がある場合は、B列を黄色で塗りつぶす ------------------------------------------------------- 'B列のデータを配列に格納 Dim data As Variant data = ws.Range("B1:B" & lastRow).Value '先頭から半角スペースまでの文字列を格納する配列を宣言 Dim strArray() As String ReDim strArray(1 To UBound(data)) '配列の各要素に対して、先頭から半角スペースまでの文字列を取り出す Dim i As Long Dim str As String For i = 1 To UBound(data) 'セルの値を文字列に変換 str = CStr(data(i, 1)) '半角スペースの位置を検索 Dim spacePos As Long spacePos = InStr(str, " ") '半角スペースがある場合は、先頭から半角スペースまでの文字列を取り出す If spacePos > 0 Then str = Left(str, spacePos - 1) End If '取り出した文字列を別の配列に格納 strArray(i) = str Next i '現在の条件付き書式をクリア ws.Range("B1:C" & lastRow).FormatConditions.Delete '別の配列の要素を重複チェックする Dim j As Long Dim k As Long For j = 1 To UBound(strArray) - 1 For k = j + 1 To UBound(strArray) '同じ文字列がある場合は、対応する行のB列のセルの背景色を黄色にする If strArray(j) = strArray(k) Then Range("B" & j).Interior.Color = vbYellow Range("B" & k).Interior.Color = vbYellow End If Next Next '----------------------------------- 'B列で黄色に着色されている行をシート「重複」に書き出す '重複シートを変数に格納 Dim ws2 As Worksheet Set ws2 = Worksheets("重複") '初期化 ws2.Columns("A:C").Clear 'DATAシートのB列の最終行を取得 lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row If lastRow >= 2 Then '重複シートの書き出し行 Dim nextRow As Long nextRow = 2 'DATAシートのB列のデータをループでチェック For i = 1 To lastRow 'B列のセルの背景色が黄色の場合 If ws.Cells(i, "B").Interior.Color = vbYellow Then 'その行のデータを重複シートにコピー ws.Rows(i).Copy ws2.Rows(nextRow) '重複シートの次の行を更新 nextRow = nextRow + 1 End If Next Else MsgBox "何もファイルがありませんが ?" Exit Sub End If '---------------------------------- 'シート「重複」のB列の各行の先頭の文字が空白（全角スペース、半角スペース）であればセルを緑色に着色 '重複シートのB列の最終行を取得 lastRow = ws2.Cells(ws2.Rows.Count, "B").End(xlUp).Row '処理の是非 If lastRow <= 1 Then MsgBox "重複ファイルは存在しません。" Exit Sub End If '重複シートのB列のデータをループでチェック For i = 1 To lastRow 'B列のセルの値を文字列に変換 str = CStr(ws2.Cells(i, "B").Value) '先頭の文字が空白（全角スペース、半角スペース）であればセルを緑色に着色 If Left(str, 1) = " " Or Left(str, 1) = " " Then ws2.Cells(i, "B").Interior.Color = vbGreen End If Next i MsgBox "先頭の文字が空白の場合は、緑色で塗りつぶしています。" '------------------------------ 'メッセージを表示 MsgBox "出力が完了しました。", vbInformation, "完了" Set ws = Nothing End Sub Private Function FolderPicker(Optional caption As Variant, Optional iniPath As Variant) As String With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False If IsMissing(caption) Then caption = "フォルダを選択" .Title = caption If Not IsMissing(iniPath) Then .InitialFileName = iniPath If .Show Then FolderPicker = .SelectedItems(1) End If End With End Function Private Sub GetFiles(ByVal path$, ByRef dic As Object, ByVal regPattern$, Optional ByVal AllDirectories As Boolean = False) If dic Is Nothing Then Set dic = CreateObject("Scripting.Dictionary") Static RegEx As Object If RegEx Is Nothing Then Set RegEx = CreateObject("VBScript.RegExp") RegEx.Pattern = regPattern Static FSO As Object If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject") Dim oFolder As Object, f As Object, flag As Boolean Set oFolder = FSO.GetFolder(path) 'ドライブ指定の場合 If (Not oFolder.isRootFolder) And (oFolder.Attributes And (FileAttribute.System + FileAttribute.Hidden)) Then Exit Sub 'フォルダー指定の場合 'If oFolder.Attributes And (FileAttribute.System + FileAttribute.Hidden) Then Exit Sub On Error Resume Next For Each f In oFolder.Files flag = False flag = RegEx.Test(f.Name) If flag Then dic(f.path) = f.Name Next If AllDirectories Then For Each f In oFolder.SubFolders Call GetFiles(f.path, dic, regPattern, AllDirectories) Next End If End Sub （増毛） 2024/02/10(土) 06:50:16 ---- 書き忘れましたが、 ファイルの破損を疑って マクロをコピーして別のEXCELファイルを作成してマクロを貼り付けて 試してみましたが同じく重複が無くてもlastRowが「1」とローカルウインドウに表示されます。 （増毛） 2024/02/10(土) 06:55:21 ---- ＞lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row Rowプロパティをみているのだから、1が最小では? あなたのExcelに0行が存在するなら0になることもあるかもしれませんが （row） 2024/02/10(土) 07:22:04 ---- ありがとうございます。 あー、なんたる初歩的なミスでアドバイスを頂くまで気が付きませんでした。 変更しました。 ws.Cells(Rows.Count, ”B”).End(xlUp).row （増毛） 2024/02/10(土) 07:46:32 ---- やっぱりで最終行番号は間違いないと思います。 ws.Cells(Rows.Count, "B").End(xlUp).row （増毛） 2024/02/10(土) 08:03:19 ---- んー、変更箇所を見る限り、伝わっているのかビミョーですが、 ＞ws.Cells(Rows.Count, ”B”).End(xlUp).row wsのCells(全行数を数えた数,B列)から、 ctrl+↑キーの挙動をして到達したセルの行番号を返しているので、 到達したセルに値があろうが無かろうが、Rowプロパティを見たら、 A1セル(R1C1)が最上最左である限り、最小値は1という事です （row） 2024/02/10(土) 08:09:52 ---- 思い込みがあって完全に理解が間違っていました。 ご指摘通りで最小値は、1でゼロではありません。 なんどもありがとうございます。 （増毛） 2024/02/10(土) 08:22:20 ---- 自分の環境では「2024/02/09(金) 18:45:02」のコードで重複チェックはできています。 1点だけ気になるのは、スピル機能を使っているのでExcel2021,365限定ということです。 増毛さんはExcel2021とあったので..... lastRowの事だけコメントすると、「dic.Count」で行数が得られるので、1行目が見出しなら lastRow = dic.Count +1 となります。 すみませんが、他人のコードを追うのは非常に疲れるので私は、ここまでとさせてください。 （まる2021） 2024/02/10(土) 08:52:18 ---- まる2021さん、お世話になりました。 最後までお付き合い願いありがとうございました。 （他人のコードを追うのは非常に疲れる。） （増毛） 2024/02/10(土) 11:27:57 ---- せっかく書いたので、後から検索した人のために、正規表現でファイル検索するメソッドを汎用化してみました。 検証不十分なのでバグがあるかもしれませんが、自由に改造して使ってください。 Private Enum FileAttribute Normal = 0 ReadOnly = 1 Hidden = 2 System = 4 Volume = 8 Directory = 16 Archive = 32 End Enum Private Function FolderPicker(Optional caption As Variant, Optional iniPath As Variant) As String With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False If IsMissing(caption) Then caption = "フォルダを選択" .Title = caption If Not IsMissing(iniPath) Then .InitialFileName = iniPath If .Show Then FolderPicker = .SelectedItems(1) End If End With End Function 'FSO+正規表現を使って指定フォルダ内のファイルを取得 '戻り値:なし。結果は第2引数のDictionaryに格納される。 '第1引数:取得対象フォルダ '第2引数:Dictionary（Key:フルパス） ' Value:第4引数が「False=規定値」ならファイル名 ' Value:第4引数が「True」なら0Base配列、要素(0)にはファイル名、以降はSubMatch '第3引数:正規表現パターン '第4引数:SubMatchesを結果に含める場合「True」を指定。規定値「False」 '第5引数:サブフォルダも検索する場合「True」を指定。規定値「False」 Private Sub GetFiles(ByVal path$, ByRef dic As Object, ByVal regPattern$, _ Optional ByVal IncludeSubMatches As Boolean = False, _ Optional ByVal AllDirectories As Boolean = False) If dic Is Nothing Then Set dic = CreateObject("Scripting.Dictionary") Static RegEx As Object If RegEx Is Nothing Then Set RegEx = CreateObject("VBScript.RegExp") RegEx.Pattern = regPattern Static FSO As Object If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject") Dim oFolder As Object, f As Object, mc Set oFolder = FSO.GetFolder(path) If (Not oFolder.isRootFolder) And (oFolder.Attributes And (FileAttribute.System + FileAttribute.Hidden)) Then Exit Sub On Error Resume Next For Each f In oFolder.Files Set mc = Nothing Set mc = RegEx.Execute(f.Name) If Not mc Is Nothing Then If mc.Count > 0 Then If IncludeSubMatches Then Dim arr, cnt& ReDim arr(0 To mc(0).SubMatches.Count) arr(0) = f.Name If mc(0).SubMatches.Count > 0 Then For cnt = 1 To mc(0).SubMatches.Count arr(cnt) = mc(0).SubMatches(cnt - 1) Next End If dic(f.path) = arr Else dic(f.path) = f.Name End If End If End If Next If AllDirectories Then For Each f In oFolder.SubFolders Call GetFiles(f.path, dic, regPattern, IncludeSubMatches, AllDirectories) Next End If End Sub '指定フォルダ内のファイルのBaseNameと拡張子を正規表現で取得するサンプル Sub GetFilesSample() Dim path$, dic As Object, k, i&, n& path = FolderPicker If path = "" Then Exit Sub Call GetFiles(path, dic, "^(.*)¥.(.*)$", IncludeSubMatches:=True, AllDirectories:=True) Cells.Clear If dic.Count > 0 Then [A1] = "FullPath" If IsArray(dic.Items()(0)) Then n = UBound(dic.Items()(0)) For i = 0 To n [B1].Offset(, i) = IIf(i = 0, "FileName", "SubMatches(" & i - 1 & ")") Next i = 0 For Each k In dic [A2].Offset(i).Value = k [B2].Offset(i).Resize(, n + 1).Value = dic(k) i = i + 1 Next End If End Sub （まる2021） 2024/02/10(土) 11:42:08... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/202402/20240208144349.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97012 documents and 608132 words.
訪問者：