[[20240208144349]]　『ファイルの削除』（増毛）　ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) |

| 全文検索 | 過去ログ ]

　

『ファイルの削除』（増毛）

外付け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が「１」とローカルウインドウに表示されます。

（増毛） 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

---

コメント返信：

---

[ 一覧(最新更新順) ]

---

YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.