【ExcelVBA】複数のフォルダにある同じ名前のファイル全てを1つのフォルダにコピーするには

33分

SHARE

この記事では、複数のフォルダにある同じ名前のファイル全てを1つのフォルダにコピーする方法についてご説明します。

すぐにソースコードを見たい場合はこちらをクリック

【動画】フォルダ内のExcelファイルにあるモジュールを全てエクスポートする実際の動き

本題に入る前に、まずは次の動画をご覧ください。


同じ名前のファイルがコピー元に3つある場合は名前が重複するので、そのファイル全てを1つのフォルダにコピーすると名前が重複するのでコピーができません。

そこで、Aの「data.txt」のファイル名はそのまま、Bの「data.txt」のファイル名は「data_1.txt」、Cの「data.txt」のファイル名は「data_2.txt」と名前を変えてコピーするように対応しています。

マクロ作成の流れ

STEP.1
【マクロ】マクロがコマンドプロンプトを呼び出す
マクロがコマンドプロンプトを呼び出します。
STEP.2
【コマンドプロンプト】コマンドプロンプトでdirコマンドを実行してフォルダ・ファイルのパスの一覧を取得する
コマンドプロンプトでdirコマンドを実行してフォルダ・ファイルのパスの一覧を取得します。
取得したフォルダ・ファイル一覧はCSVに出力します。
STEP.3
【マクロ】フォルダ名・ファイル名を列挙するためのシートを新規作成
フォルダ名・ファイル名を列挙するためのシートを新規作成します。
STEP.4
【マクロ】STEP.2のCSVファイルを読み込む
STEP.2のCSVファイルを読み込みます。
STEP.5
【マクロ】STEP.4で読み込んだファイルをコピー先にコピーする
STEP.4で読み込んだファイルをコピー先にコピーします。
すでにコピー先に同じ名前のファイルがある場合はファイル名に「_1」を付けてコピーします。
さらにコピーする際に「_1」付きのファイルが存在する場合は1の値を一つ増やし、その値をファイル名に付けてコピーします。
例えば同じ名前のファイルがコピー元に3つある場合は、コピー先に「data.txt」「data_1.txt」「data_2.txt」というように3つのファイルがコピーされます。
中身はそのままコピーされ、重複しているファイル名がリネームされます。
STEP.6
【マクロ】フォルダ名・ファイル名を列挙するためのシートを新規作成
フォルダ名・ファイル名を列挙するためのシートを新規作成します。
STEP.7
【マクロ】STEP.3で作成したシートにコピーしたファイル名を書き出す
STEP.3で作成したシートにコピーしたファイル名を書き出します。
目次へ戻る

Excelファイルの例

今回は次のExcelファイルを作成しました。

配置されているコントロールやセルの名前は次の通りです。

searchpath

フォルダやファイルを探す対象のフォルダパスを指定するセルに、「searchpath」という名前を付けます。

例えば、Cドライブ配下全てでフォルダやファイルを検索する場合は「c:\」または「c:」と入力します。

filePath

ファイルのコピー先を指定するセルに、「filePath」という名前を付けます。

ファイルのコピーしてそのコピーしたファイルを保存する場所をこのセルに指定します。

マクロを実行すると、下の画像のようにファイルのコピー先にファイルがコピーされます。

searchStr

探したいフォルダ名やファイル名、もしくは探したいフォルダやファイルの文字列の一部を入力するセルに「searchStr」という名前を付けます。

このセルに探したいファイル名、もしくは探したいファイルの文字列の一部を入力して検索します。

例えば、「work.xlsm」というファイルをコピーする場合は、このセルに「work.xlsm」と入力し、検索するとファイルがコピー先にコピーされます。

上の画像はCドライブ配下にある全ての「work.xlsm」をコピーした後のコピー先のフォルダですが、名前が重複するためファイル名の後に数値を付けて重複を回避しています。

なお、どこにあった「work.xlsm」なのかフォルダの中身を見ても分からないので、どこのフォルダからコピーしたのかが分かるように、今回のサンプルではシート「data」にコピー元がどこなのかを分かるよう一覧表示させています。

opb_allmatch(フォームコントロール)

ファイルを「完全一致」で検索し、ファイル名が合致するファイルをコピーするよう設定するオプションボタンです。

ファイル名が完全に一致するファイルをコピーします。

もし同じ名前のファイルが複数ある場合は、コピーする際にファイル名に「_1」のように数値を付けて名前をリネームしています。

Excelファイルの設定(ファイル名が「0204.xlsm」のファイルをコピー)

コピー元

コピー先

opb_partmatch(フォームコントロール)

ファイルを「部分一致」で検索し、ファイル名が合致するファイルをコピーするよう設定するオプションボタンです。

もし同じ名前のファイルが複数ある場合は、コピーする際にファイル名に「_1」のように数値を付けて名前をリネームしています。

Excelファイルの設定(ファイル名に「test_0204」を含むファイルをコピー)

コピー元

コピー先

opb_fwdmatch(フォームコントロール)

ファイルを「前方一致」で検索し、ファイル名が合致するファイルをコピーするよう設定するオプションボタンです。

もし同じ名前のファイルが複数ある場合は、コピーする際にファイル名に「_1」のように数値を付けて名前をリネームしています。

Excelファイルの設定(ファイル名が「old_sample」で始まるファイルをコピー)

コピー元

コピー先

opb_rearmatch(フォームコントロール)

ファイルを「後方一致」で検索し、ファイル名が合致するファイルをコピーするよう設定するオプションボタンです。

もし同じ名前のファイルが複数ある場合は、コピーする際にファイル名に「_1」のように数値を付けて名前をリネームしています。

Excelファイルの設定(ファイル名が「data_0204.xlsx」で終わるファイルをコピー)

コピー元

コピー先

目次へ戻る

コードの例

Option Explicit

Private Sub btn_exec_Click()

    Dim fNMExptTxt          As String               'ファイル名が出力されたファイル名
    Dim rPos_cnt            As Long                 'シートの行位置用カウンタ
    Dim copyCnt             As Long                 'コピーする回数用カウンタ
    Dim fileNMCnt           As Long                 'ファイルに項番を振る用のカウンタ
    Dim sheetExistChk       As Boolean              'シート「work」の存在チェックフラグ
    Dim getPath             As String               'サブフォルダ含めて全てのファイル名を取得したいパス
    Dim copyToPath          As String               'ファイルのコピー先のパス
    Dim searchStr           As String               'コピーする対象の文字列
    Dim st                  As ADODB.Stream         'バイナリ データまたはテキストのストリームのインスタンス用変数
    Dim fso                 As FileSystemObject     'FileSystemObjectのインスタンス用変数
    Dim wshObj              As WshShell             'WshShellオブジェクト
    Dim folder              As folder               'フォルダ用変数
    Dim cmdTxt              As String               'コマンドプロンプトのコード用変数
    Dim ws                  As Worksheet            'Worksheet用変数
    Dim buf                 As String               '一時的な値の格納先変数

    Dim copiedFile          As String               'コピーしたファイル
    Dim copieFlg            As Boolean              'コピーするか判定するフラグ
    Dim drive               As Object               'ドライブ用変数
    Dim freeSpace           As Long                 'ドライブの空き容量
        
    '出力ファイルを一意にするため、年月日時分秒をファイル名に付ける
    fNMExptTxt = ActiveWorkbook.Path & "\" & "data.csv"
    
    'シートの行位置用カウンタの初期値を設定
    rPos_cnt = 2
        
    'コピーする回数をカウンタを初期化する
    copyCnt = 1
    
    'ファイルに項番を振る用のカウンタを初期化する
    fileNMCnt = 1
    
    'シート「work」の存在チェックフラグを初期化する
    sheetExistChk = False
        
    'サブフォルダ含めて全てのファイル名を取得したいパス
    getPath = Sheets("top").Range("searchpath").Value
    
    'ファイルのコピー先のパスを取得する
    copyToPath = Sheets("top").Range("filePath").Value
    
    '検索文字列を取得する
    searchStr = Sheets("top").Range("searchStr").Value
            
    'バイナリ データまたはテキストのストリームのインスタンスを生成する
    Set st = New ADODB.Stream
    
    'FileSystemObjectのインスタンスを生成する
    Set fso = New FileSystemObject
    
    'WshShellオブジェクトからインスタンスを生成する
    Set wshObj = New WshShell
        
    If Right(getPath, 1) <> "\" Then
    
        '入力されたパスの末尾に「\」が付いていない場合に付ける
        getPath = getPath & "\"
        
    End If
        
    If Right(copyToPath, 1) <> "\" Then
    
        '入力されたパスの末尾に「\」が付いていない場合に付ける
        copyToPath = copyToPath & "\"
        
    End If
                
    'ファイルのコピー先のフォルダを取得する
    Set folder = fso.GetFolder(copyToPath)

    If folder.Files.Count > 0 Then
    
        'フォルダ内にファイルが存在する場合
    
        'フォルダ内のファイルを全て削除する
        fso.DeleteFile copyToPath & "*.*"
    
    End If
    
    '実行するコマンド：dirコマンドでフルパスをCSVファイルに書き出す
    cmdTxt = "chcp 65001 | dir " & getPath & "*" & searchStr & "* /b /s > " & fNMExptTxt & " /B"
        
    'コマンドプロンプトで変数「cmdTxt」のコマンドを実行する
    Call wshObj.Run("%ComSpec% /c " & cmdTxt, 1, WaitOnReturn:=True)
    
    If fso.OpenTextFile(fNMExptTxt, 8).Line - 1 = 0 Then
    
        '検索対象のファイルが無い場合
    
        '処理を終了する
        Exit Sub
        
    End If
    
    'ファイル名の貼り付け用シート有無のチェック
    For Each ws In Worksheets
    
        If ws.Name = "data" Then
            
            'シート名が「data」の場合
            
            'シート「data」の存在チェックフラグにTrueを設定する
            sheetExistChk = True

            With Worksheets(ws.Name)

                'シート「data」のセルをクリアする
                .Cells.Clear
                
                'C列のセルの書式を文字列に設定する
                .Columns("C").NumberFormatLocal = "@"
                
                '1行目に項目を設定する
                .Range("A1").Value = "コピー元のファイルパス"
                .Range("B1").Value = "コピー元のファイル名"
                .Range("C1").Value = "コピーしたファイル"
                
            End With
            
        End If
        
    Next ws
                   
    If sheetExistChk = False Then

        'シート「data」が存在しない場合

        'ファイル名を列挙するためのシートを新規作成する
        Worksheets.Add(After:=Worksheets(Worksheets.Count)) _
                       .Name = "data"
        
        With Worksheets("data")
        
            'C列のセルの書式を文字列に設定する
            .Columns("C").NumberFormatLocal = "@"
        
            '1行目に項目を設定する
            .Range("A1").Value = "コピー元のファイルパス"
            .Range("B1").Value = "コピー元のファイル名"
            .Range("C1").Value = "コピーしたファイル"
                
        End With
        
    End If
    
    With st
    
        .Charset = "UTF-8"              '文字セットにUTF-8を設定する
        .Open                           'streamを開く
        .LoadFromFile fNMExptTxt        'ファイル名が出力されたファイルから読み込む
        
        'Streamの末尾まで繰り返す
        Do Until .EOS
        
            '取り出したテキストを変数「buf」に格納する
            buf = .ReadText(adReadLine)
                        
            'フルパスがフォルダなのかファイルなのかを判定する(Ture：ファイル／False：フォルダ)
            If fso.FileExists(buf) Then
                
                'ファイルの場合
                
                'ファイル名を取得する
                copiedFile = fso.GetFileName(buf)
                        
                If Sheets("top").OptionButtons("opb_allmatch").Value = 1 Then
            
                    '完全一致の場合
            
                    If copiedFile = searchStr Then
                    
                        'CSVファイルから取得したファイル名と、ファイルの検索対象の文字列が完全一致する場合
                                            
                        'ファイルをコピーするためコピーフラグをTrueに設定する
                        copieFlg = True
                    
                    End If
            
                ElseIf Sheets("top").OptionButtons("opb_partmatch").Value = 1 Then
            
                    '部分一致の場合
            
                    If InStr(copiedFile, searchStr) > 0 Then
                    
                        'CSVファイルから取得したファイル名と、ファイルの検索対象の文字列が部分一致する場合

                        'ファイルをコピーするためコピーフラグをTrueに設定する
                        copieFlg = True

                    End If
                            
                ElseIf Sheets("top").OptionButtons("opb_fwdmatch").Value = 1 Then
            
                    '前方一致の場合
            
                    If InStr(copiedFile, searchStr) = 1 Then
                    
                        'CSVファイルから取得したファイル名と、ファイルの検索対象の文字列が前方一致する場合

                        'ファイルをコピーするためコピーフラグをTrueに設定する
                        copieFlg = True

                    End If
            
                ElseIf Sheets("top").OptionButtons("opb_rearmatch").Value = 1 Then
            
                    '後方一致の場合
                    
                    If Right(copiedFile, Len(searchStr)) = searchStr Then
                    
                        'CSVファイルから取得したファイル名と、ファイルの検索対象の文字列が後方一致する場合
                    
                        'ファイルをコピーするためコピーフラグをTrueに設定する
                        copieFlg = True
                        
                    End If
            
                End If
                       
                If copieFlg Then
                
                    'コピーフラグがTrueの場合
                                    
                    'ファイルのコピー先のドライブレターを取得する
                    Set drive = fso.GetDrive(Left(copyToPath, 2))
                    
                    'ドライブの空き容量をMB単位で取得する
                    freeSpace = drive.freeSpace / 1024 / 1024
                    
                    If freeSpace < 500 Then
                    
                        'コピー先ドライブの残りサイズが500MB未満の場合
                        
                        '処理を終了するための確認メッセージを表示する
                        MsgBox ("コピー先のドライブの空き容量が不足しているので処理を終了します。" & Chr(10) & _
                                drive.driveLetter & "ドライブの空き容量：" & freeSpace & "MB")
                        
                        '処理を終了します
                        Exit Sub
                        
                    End If
                    
                    If fso.FileExists(copyToPath & copiedFile) Then
                    
                        'コピー先に同じ名前のファイルが存在する場合
                        
                        If fso.GetExtensionName(buf) = "" Then
                        
                            'ファイルに拡張子がない場合
                            
                            '項番が振られたファイルがコピー先に存在しない間はループを繰り返すDoループ
                            Do While (fso.FileExists(copyToPath & copiedFile & "_" & fileNMCnt))
                            
                                'ファイルをコピーするために、ファイルに項番を振るためのカウンタを1つ増やす
                                fileNMCnt = fileNMCnt + 1
                            
                                DoEvents
                                
                            Loop
                            
                            'コピーするファイル名を取得する
                            copiedFile = copiedFile & "_" & fileNMCnt
                            
                        Else
                        
                            'ファイルに拡張子がある場合
                        
                            '項番が振られたファイルがコピー先に存在しない間はループを繰り返すDoループ
                            Do While (fso.FileExists(copyToPath & Split(copiedFile, ".")(0) & "_" & fileNMCnt & "." & Split(copiedFile, ".")(1)))
                            
                                'ファイルをコピーするために、ファイルに項番を振るためのカウンタを1つ増やす
                                fileNMCnt = fileNMCnt + 1
                            
                                DoEvents
                                
                            Loop
                            
                            'コピーするファイル名を取得する
                            copiedFile = Split(copiedFile, ".")(0) & "_" & fileNMCnt & "." & Split(copiedFile, ".")(1)
                        
                        End If
                            
                        'ファイルをコピーする
                        fso.copyFile buf, copyToPath & copiedFile
                        
                    Else
                                            
                        'ファイルをコピーする
                        fso.copyFile buf, copyToPath & copiedFile
                        
                    End If
                                            
                    'フルパスからパスを切り出してA列に設定する
                    Sheets("data").Cells(rPos_cnt, 1).Value = Left(buf, Len(buf) - Len(fso.GetFileName(buf)) - 1)
                    
                    'フルパスからファイル名を切り出してB列に設定する
                    Sheets("data").Cells(rPos_cnt, 2).Value = fso.GetFileName(buf)
                    
                    'コピーしたファイル名をC列に設定する
                    Sheets("data").Cells(rPos_cnt, 3).Value = copiedFile
                    
                    'コピー元のファイルのリンクをセルに設定する
                    Sheets("data").Cells(rPos_cnt, 3).Hyperlinks.Add _
                    Anchor:=Sheets("data").Cells(rPos_cnt, 3), _
                    Address:=Sheets("data").Cells(rPos_cnt, 1).Value
                
                    copieFlg = False
                    
                    copyCnt = copyCnt + 1
            
                    rPos_cnt = rPos_cnt + 1
                    
                    fileNMCnt = 1
                
                End If
                
            End If
            
            DoEvents
            
        Loop
        
        'Streamの末尾まで処理が終わったので、streamを閉じる
        .Close
        
    End With
    
    'コピー先のフォルダを開く
    Shell "explorer.exe " & copyToPath & "", vbNormalFocus
    
    '後処理
    Set st = Nothing
    Set fso = Nothing
    Set wshObj = Nothing
    Set folder = Nothing
    Set drive = Nothing
    
End Sub

注目すべきコード①

最初に見て頂きたいのは51行目から57行目です。

    'バイナリ データまたはテキストのストリームのインスタンスを生成する
    Set st = New ADODB.Stream
    
    'FileSystemObjectのインスタンスを生成する
    Set fso = New FileSystemObject
    
    'WshShellオブジェクトからインスタンスを生成する
    Set wshObj = New WshShell

コードの説明

以上のコードは、バイナリ データまたはテキストのストリーム、FileSystemObjectのオブジェクト、WshShell、それぞれのインスタンスを生成を行うコードです。

バイナリ データまたはテキストのストリームのインスタンスは、CSVファイルに書き込まれている文字列を取得するのに必要です。

FileSystemObjectのオブジェクトのインスタンスは、ファイルの有無確認やファイル名の取得、ファイルの拡張子やファイルのコピーなど、ファイルの操作に関する処理を行うのに必要です。

WshShellのインスタンスは、コマンドプロンプトのコマンドを実行するのに必要です。

注目すべきコード②

次に見て頂きたいのは74行目から83行目です。

    'ファイルのコピー先のフォルダを取得する
    Set folder = fso.GetFolder(copyToPath)

    If folder.Files.Count > 0 Then
    
        'フォルダ内にファイルが存在する場合
    
        'フォルダ内のファイルを全て削除する
        fso.DeleteFile copyToPath & "*.*"
    
    End If

コードの説明

以上のコードは、コピー先のフォルダを取得し、そのフォルダ配下のファイルを全て削除する処理のコードです。

ファイルをコピーする処理を行う際は、コピー先のフォルダ配下にファイルは残しておきたくないので、このコードでファイルを全て削除しておきます。

コードの詳細

74行目では、コピー先のフォルダ名のパスを取得して変数folderに格納しています。

76行目では、コピー先のフォルダー内のファイル件数をCountプロパティで取得し、1つでもファイルがあるかを判定しています。

もし1つでもファイルがある場合は、81行目でコピー先のフォルダにあるファイルをDeleteFileメソッドで削除しています。

注目すべきコード③

次に見て頂きたいのは86行目から89行目です。

    '実行するコマンド：dirコマンドでフルパスをCSVファイルに書き出す
    cmdTxt = "chcp 65001 | dir " & getPath & "*" & searchStr & "* /b /s > " & fNMExptTxt & " /B"
        
    'コマンドプロンプトで変数「cmdTxt」のコマンドを実行する
    Call wshObj.Run("%ComSpec% /c " & cmdTxt, 1, WaitOnReturn:=True)

コードの説明

以上のコードは、コマンドプロンプトを呼び出してサブフォルダ含めて検索する全てのファイル名を取得したいパスをCSVファイルに書き出す処理です。

なぜわざわざコマンドプロンプトを使っているのか(呼び出しているのか)というと、処理の高速化を図るためです。

例えばCドライブ配下の全てのファイルから検索する場合、大量のファイルから検索することになります。

ちなみに私のパソコンのCドライブには250万を超えるファイルが存在します。

このように大量のファイルの中から検索するのにマクロだけでやろうとすると時間がかかりすぎるため、高速化が実現できるコマンドプロンプトを使っています。
(※絶対にコマンドプロンプトを使わなければいけないというわけではありませんが、今回は手軽に使うことができるコマンドプロンプトを採用しました)

コードの詳細

86行目でフォルダ名とファイル名を出力させるCSVファイルの出力を行うコマンド文(dirコマンド)を変数「cmdTxt」に格納し、89行目でそのコマンドをコマンドプロンプトで実行します。

コマンドの例

chcp 65001 | dir C:\*work.xlsm* /b /s > C:\work\10_勉強\10_VBA関連\0204\data.csv /B

ちなみに、dirコマンド実行後に出力されるファイルの一覧(CSVファイル)は、Excelのシートに書き出されます。

なお、コマンドプロンプトで実行するコマンド文は、実は2つのコマンドを1行で実行しています。

2つのコマンド(例)は次の通りです。(コマンド文は「部分一致」のコマンド文)

  1. chcp 65001
  2. dir C:\*work.xlsm* /b /s > C:\work\10_勉強\10_VBA関連\0204\data.csv /B
コマンドの説明
  1. ①のコマンドは、文字コードをUTF-8に設定するコマンドで、文字化けしないように文字コードをUTF-8に設定しています。
    (文字コードをUTF-8に設定すると文字化けしない)
  2. ②のコマンドは、ファイル名が「work.xlsm」のファイルを検索し、見つかったファイルのフルパスを「data.csv」に書き出しています。「data.csv」の作成場所は「C:\work\10_勉強\10_VBA関連\0204」です。
コマンドの「|」とは？
コマンドで使われている「|」の文字は、実行する複数のコマンドを1行で記述したい時に使う文字です。

以上、上記のコマンドが実行されると、ファイル名が出力された「data.csv」というファイルが出力されます。

注目すべきコード④

次に見て頂きたいのは92行目から99行目です。

    If fso.OpenTextFile(fNMExptTxt, 8).Line - 1 = 0 Then
    
        '検索対象のファイルが無い場合
    
        '処理を終了する
        Exit Sub
        
    End If

コードの説明

以上のコードは、検索対象のファイルの有無を確認し、無ければ処理を終了するコードです。

コードの詳細

91行目のOpenTextFileメソッドの引数に作成されたCSVファイルを指定し実行すると、Lineプロパティの値にそのCSVファイルの行数が取得されます。

この行数が1以上あれば検索したファイルが存在していることが分かります。

もし0行なら96行目のExit Subで処理を終了しています。

注目すべきコード⑤

次に見て頂きたいのは101行目から127行目です。

    'ファイル名の貼り付け用シート有無のチェック
    For Each ws In Worksheets
    
        If ws.Name = "data" Then
            
            'シート名が「data」の場合
            
            'シート「data」の存在チェックフラグにTrueを設定する
            sheetExistChk = True

            With Worksheets(ws.Name)

                'シート「data」のセルをクリアする
                .Cells.Clear
                
                'C列のセルの書式を文字列に設定する
                .Columns("C").NumberFormatLocal = "@"
                
                '1行目に項目を設定する
                .Range("A1").Value = "コピー元のファイルパス"
                .Range("B1").Value = "コピー元のファイル名"
                .Range("C1").Value = "コピーしたファイル"
                
            End With
            
        End If
        
    Next ws

コードの説明

以上のコードは、「注目すべきコード③」で作成した「data.csv」ファイルの中にあるファイルの一覧を書き出すシートが存在しない場合に作成する処理のコードです。

コードの詳細

101行目では、ブック内の全てのシートを参照するFor文です。

このFor文内でブック内のシートを全て一つ一つ参照していきます。

103行目では、参照しているのがシート「data」がどうかを判定します。

もしシート「data」の場合は、シート「data」がブック内に存在するかを知らせるフラグsheetExistChkをTrueに設定します。

さらに113行目ではシート「data」をクリア、116行目ではC列の書式を文字列に設定、そして119行目から121行目でセルA1からC1までデータの項目名を出力しています。

C列の書式を文字列にしているのはファイル名が数値だけのものもあることを考慮して念のため書式を文字列に設定しています。

データの項目名を出力まで行った直後のシート「data」の状態は下の通りです。

注目すべきコード⑥

次に見て頂きたいのは129行目から149行目です。

    If sheetExistChk = False Then

        'シート「data」が存在しない場合

        'ファイル名を列挙するためのシートを新規作成する
        Worksheets.Add(After:=Worksheets(Worksheets.Count)) _
                       .Name = "data"
        
        With Worksheets("data")
        
            'C列のセルの書式を文字列に設定する
            .Columns("C").NumberFormatLocal = "@"
        
            '1行目に項目を設定する
            .Range("A1").Value = "コピー元のファイルパス"
            .Range("B1").Value = "コピー元のファイル名"
            .Range("C1").Value = "コピーしたファイル"
                
        End With
        
    End If

コードの説明

以上のコードは、シート「data」が存在しない場合にシート「data」の作成や、そのシートに必要な設定を行う処理のコードです

コードの詳細

129行目では、sheetExistChkの値がFalseかを判定し、Falseの場合はシート「data」が存在していないので134行目と135行目でシート「data」を作成します。

シート「data」を作成したら、140行目ではC列の書式を文字列に設定、そして143行目から145行目でセルA1からC1までデータの項目名を出力しています。

C列の書式を文字列にしているのはファイル名が数値だけのものもあることを考慮して念のため書式を文字列に設定しています。

注目すべきコード⑦

次に見て頂きたいのは151行目から155行目です。

    With st
    
        .Charset = "UTF-8"              '文字セットにUTF-8を設定する
        .Open                           'streamを開く
        .LoadFromFile fNMExptTxt        'ファイル名が出力されたファイルから読み込む

コードの説明

以上のコードは、streamを開き、そのCSVファイル内を開く処理のコードです。

この処理により、「data.csv」の中身を参照したり取得することができるようになります。

文字列を取得する際は文字セットにUTF-8を設定します。

コードの詳細

151行目のstはバイナリ データまたはテキストのストリームのインスタンスです。

153行目では、このインスタンスstのCharsetプロパティに「UTF-8」を設定しています。

「data.csv」はUTF-8形式で作成されているので、Charsetプロパティに「UTF-8」を設定しておきます。

154行目では、Openメソッドを実行してstreamを開きます。

155行目では、LoadFromFileメソッドに「data.csv」のフルパスを指定して実行し、「data.csv」を開きます。

注目すべきコード⑧

次に見て頂きたいのは158行目から169行目です。

        'Streamの末尾まで繰り返す
        Do Until .EOS
        
            '取り出したテキストを変数「buf」に格納する
            buf = .ReadText(adReadLine)
                        
            'フルパスがフォルダなのかファイルなのかを判定する(Ture：ファイル／False：フォルダ)
            If fso.FileExists(buf) Then
                
                'ファイルの場合
                
                'ファイル名を取得する
                copiedFile = fso.GetFileName(buf)

コードの説明

以上のコードは、読み込んだ「data.csv」のファイルまで繰り返すループと、そのループ内で「data.csv」のファイル内のデータを1行ずつ取り出しファイル名を取得する処理のコードです。

コードの詳細

158行目では、読み込んだ「data.csv」のファイルまで繰り返すループで、161行目では取り出したファイルのフルパスを変数bufに格納しています。

164行目では、変数bufの値がファイルかどうかを判定し、ファイルだったら169行目でパスを除いたファイル名を変数copiedFileに格納しています。

注目すべきコード⑨

次に見て頂きたいのは171行目から223行目です。

                If Sheets("top").OptionButtons("opb_allmatch").Value = 1 Then
            
                    '完全一致の場合
            
                    If copiedFile = searchStr Then
                    
                        'CSVファイルから取得したファイル名と、ファイルの検索対象の文字列が完全一致する場合
                                            
                        'ファイルをコピーするためコピーフラグをTrueに設定する
                        copieFlg = True
                    
                    End If
            
                ElseIf Sheets("top").OptionButtons("opb_partmatch").Value = 1 Then
            
                    '部分一致の場合
            
                    If InStr(copiedFile, searchStr) > 0 Then
                    
                        'CSVファイルから取得したファイル名と、ファイルの検索対象の文字列が部分一致する場合

                        'ファイルをコピーするためコピーフラグをTrueに設定する
                        copieFlg = True

                    End If
                            
                ElseIf Sheets("top").OptionButtons("opb_fwdmatch").Value = 1 Then
            
                    '前方一致の場合
            
                    If InStr(copiedFile, searchStr) = 1 Then
                    
                        'CSVファイルから取得したファイル名と、ファイルの検索対象の文字列が前方一致する場合

                        'ファイルをコピーするためコピーフラグをTrueに設定する
                        copieFlg = True

                    End If
            
                ElseIf Sheets("top").OptionButtons("opb_rearmatch").Value = 1 Then
            
                    '後方一致の場合
                    
                    If Right(copiedFile, Len(searchStr)) = searchStr Then
                    
                        'CSVファイルから取得したファイル名と、ファイルの検索対象の文字列が後方一致する場合
                    
                        'ファイルをコピーするためコピーフラグをTrueに設定する
                        copieFlg = True
                        
                    End If
            
                End If

コードの説明

以上のコードは、Excelファイルのチェックボックス「完全一致」「部分一致」「前方一致」「後方一致」のどれに設定されているかを確認し、合致しているファイルをコピーするかを判定する処理のコードです。

ファイルが合致している場合は、変数copieFlgにTrueを設定します。

コードの詳細

171行目では、チェックボックスが「完全一致」の場合かを判定し、175行目ではCSVファイルから取得したファイル名と検索文字列が同じかを判定しています。

同じ場合は180行目で変数copieFlgにTrueを設定します。

copieFlgがTrueの場合はファイルをコピーし、Falseの場合はファイルをコピーしません。

なお、ここでいう検索文字列とは以下の矢印で示したセルに入力された文字列です。

184行目では、チェックボックスが「部分一致」の場合かを判定し、188行目ではCSVファイルから取得したファイル名の中に検索文字列が含まれているかを判定しています。

含まれている場合は192行目で変数copieFlgにTrueを設定します。

197行目では、チェックボックスが「前方一致」の場合かを判定し、201行目ではCSVファイルから取得したファイル名が検索文字列で始まるかを判定しています。

含まれている場合は207行目で変数copieFlgにTrueを設定します。

210行目では、チェックボックスが「前方一致」の場合かを判定し、214行目ではCSVファイルから取得したファイル名が検索文字列で終わるのかを判定しています。

含まれている場合は219行目で変数copieFlgにTrueを設定します。

注目すべきコード⑩

次に見て頂きたいのは226行目です。

                If copieFlg Then

コードの説明

以上のコードは、ファイルをコピーするかを判定するコードです。

copieFlgがTrueの場合はファイルをコピーし、Falseの場合はファイルをコピーします。

注目すべきコード⑪

次に見て頂きたいのは230行目から246行目です。

                    'ファイルのコピー先のドライブレターを取得する
                    Set drive = fso.GetDrive(Left(copyToPath, 2))
                    
                    'ドライブの空き容量をMB単位で取得する
                    freeSpace = drive.freeSpace / 1024 / 1024
                    
                    If freeSpace < 500 Then
                    
                        'コピー先ドライブの残りサイズが500MB未満の場合
                        
                        '処理を終了するための確認メッセージを表示する
                        MsgBox ("コピー先のドライブの空き容量が不足しているので処理を終了します。" & Chr(10) & _
                                drive.driveLetter & "ドライブの空き容量：" & freeSpace & "MB")
                        
                        '処理を終了します
                        Exit Sub
                        
                    End If

コードの説明

以上のコードは、ファイルをコピーするのにパソコンのドライブの容量を超えてファイルをコピーしないように制御する処理のコードです。

ファイルをコピーしている途中でドライブの容量が不足してしまう場合はコピー処理を終了させます。

コードの詳細

230行目では、コピー先のドライブ名を取得します。

233行目では、コピー先のドライブの容量を取得します。

235行目では、コピー先のドライブのサイズが500メガよりも小さいかどうかを判定します。

もし小さい場合は240行目でドライブのサイズが小さいので処理を終了するメッセージを出力し、244行目で処理を終了します。

注目すべきコード⑫

次に見て頂きたいのは248行目から296行目です。

                    If fso.FileExists(copyToPath & copiedFile) Then
                    
                        'コピー先に同じ名前のファイルが存在する場合
                        
                        If fso.GetExtensionName(buf) = "" Then
                        
                            'ファイルに拡張子がない場合
                            
                            '項番が振られたファイルがコピー先に存在しない間はループを繰り返すDoループ
                            Do While (fso.FileExists(copyToPath & copiedFile & "_" & fileNMCnt))
                            
                                'ファイルをコピーするために、ファイルに項番を振るためのカウンタを1つ増やす
                                fileNMCnt = fileNMCnt + 1
                            
                                DoEvents
                                
                            Loop
                            
                            'コピーするファイル名を取得する
                            copiedFile = copiedFile & "_" & fileNMCnt
                            
                        Else
                        
                            'ファイルに拡張子がある場合
                        
                            '項番が振られたファイルがコピー先に存在しない間はループを繰り返すDoループ
                            Do While (fso.FileExists(copyToPath & Split(copiedFile, ".")(0) & "_" & fileNMCnt & "." & Split(copiedFile, ".")(1)))
                            
                                'ファイルをコピーするために、ファイルに項番を振るためのカウンタを1つ増やす
                                fileNMCnt = fileNMCnt + 1
                            
                                DoEvents
                                
                            Loop
                            
                            'コピーするファイル名を取得する
                            copiedFile = Split(copiedFile, ".")(0) & "_" & fileNMCnt & "." & Split(copiedFile, ".")(1)
                        
                        End If
                            
                        'ファイルをコピーする
                        fso.copyFile buf, copyToPath & copiedFile
                        
                    Else
                                            
                        'ファイルをコピーする
                        fso.copyFile buf, copyToPath & copiedFile
                        
                    End If

コードの説明

以上のコードは、ファイルをコピー先のフォルダにコピーする処理のコードです。

ただし、複数のコピー元に同じ名前のファイルがある場合はファイル名が重複しているので、そのままコピーするわけにはいきません。

ではどうするのかというと、ファイルをリネームします。

ファイルをリネームするのに1つ命名ルールを決めています。

その命名ルールは、同じ名前のファイルが2つある場合は2つ目のファイルに項番「_1」を、3つある場合は2つ目に項番「_1」を、3つ目のファイルに項番「_2」を付与します。

例えばファイルが「work.xlsm」の場合は「work_1.xlsm」「work_2.xlsm」というようにファイルをリネームします。

また、ファイルには拡張子のものと拡張子が無いものがあるので、値の付け方が異なります。

拡張子があるファイルの場合は「work.xlsm」のファイル名のベース部分「work」に項番「_1」の値を付けて「work_1.xlsm」のように名前を付けます。

拡張子が無い場合はそのまま末尾に項番「_1」を付けます。

コピー元

コピー先

名前が決まったらファイルをコピー先にコピーします。

コードの詳細

248行目では、コピー先に同じ名前のファイルが存在するかを確認し、ファイルが存在する場合は252行目ではファイルに拡張子があるかないかを確認します。

ファイルが存在しない場合は294行目でコピー先にファイルをコピーします。

ファイルに拡張子が無い場合は、260行目でカウンタ変数fileNMCntの値に1増やします。

なお、カウンタの値を増やす処理は、項番が振られているファイルが無い場合が条件です。ファイルがあればカウンタは増やさずに257行目のループから抜けます。

ループから抜けたら、267行目でコピー先にファイルをコピーします。

ファイルに拡張子がある場合は、277行目でカウンタ変数fileNMCntの値に1増やします。

なお、カウンタの値を増やす処理は、項番が振られているファイルが無い場合が条件です。ファイルがあればカウンタは増やさずに274行目のループから抜けます。

ループから抜けたら、284行目でコピー先にファイルをコピーします。

注目すべきコード⑬

次に見て頂きたいのは299行目から310行目です。

                    'フルパスからパスを切り出してA列に設定する
                    Sheets("data").Cells(rPos_cnt, 1).Value = Left(buf, Len(buf) - Len(fso.GetFileName(buf)) - 1)
                    
                    'フルパスからファイル名を切り出してB列に設定する
                    Sheets("data").Cells(rPos_cnt, 2).Value = fso.GetFileName(buf)
                    
                    'コピーしたファイル名をC列に設定する
                    Sheets("data").Cells(rPos_cnt, 3).Value = copiedFile
                    
                    'コピー元のファイルのリンクをセルに設定する
                    Sheets("data").Cells(rPos_cnt, 3).Hyperlinks.Add _
                    Anchor:=Sheets("data").Cells(rPos_cnt, 3), _
                    Address:=Sheets("data").Cells(rPos_cnt, 1).Value

コードの説明

以上のコードは、「コピー元のファイルパス」「コピー元のファイル名」「コピーしたファイル」の3つの情報をシートに書き出す処理のコードです。

コードの詳細

299行目では、ファイルのフルパスをA列に出力します。

                    'フルパスからパスを切り出してA列に設定する
                    Sheets("data").Cells(rPos_cnt, 1).Value = Left(buf, Len(buf) - Len(fso.GetFileName(buf)) - 1)

302行目では、ファイル名をB列のセルに出力します。

                    'フルパスからファイル名を切り出してB列に設定する
                    Sheets("data").Cells(rPos_cnt, 2).Value = fso.GetFileName(buf)

305行目では、コピーしたファイル名をC列のセルに出力します。

                    'コピーしたファイル名をC列に設定する
                    Sheets("data").Cells(rPos_cnt, 3).Value = copiedFile

308行目から310行目では、コピー元のファイルのリンクをC列のセルに設定しています。

                    'コピー元のファイルのリンクをセルに設定する
                    Sheets("data").Cells(rPos_cnt, 3).Hyperlinks.Add _
                    Anchor:=Sheets("data").Cells(rPos_cnt, 3), _
                    Address:=Sheets("data").Cells(rPos_cnt, 1).Value

なぜコピー元のファイルのリンクを設定しているのかというと、どこからファイルをコピーしてきたのかが分かるようにするためです。

以上の情報をシートに書き出したイメージは下の画像の通りです。

リンクをクリックすると、コピー元のファイルのフォルダが開きます。

目次へ戻る

動作確認

①「完全一致」を選んでファイルをコピーする場合

マクロ実行前

Excelファイルの設定(ファイル名が「0204.xlsm」のファイルをコピー)

コピー元

マクロ実行後

マクロを実行すると、コピー先にファイルがコピーされました。

同じ名前のファイルが複数ある場合には、コピーする際にファイル名に項番が付けられます。

コピー先

②「部分一致」を選んでファイルをコピーする場合

マクロ実行前

Excelファイルの設定(ファイル名に「test_0204」を含むファイルをコピー)

コピー元

マクロ実行後

マクロを実行すると、コピー先にファイルがコピーされました。

同じ名前のファイルが複数ある場合には、コピーする際にファイル名に項番が付けられます。

コピー先

③「前方一致」を選んでファイルをコピーする場合

マクロ実行前

Excelファイルの設定(ファイル名が「old_sample」で始まるファイルをコピー)

コピー元

マクロ実行後

マクロを実行すると、コピー先にファイルがコピーされました。

同じ名前のファイルが複数ある場合には、コピーする際にファイル名に項番が付けられます。

コピー先

④「後方一致」を選んでファイルをコピーする場合

マクロ実行前

Excelファイルの設定(ファイル名が「data_0204.xlsx」で終わるファイルをコピー)

コピー元

マクロ実行後

コピー先

目次へ戻る

【注意】参照設定が必要です

一つ注意点があるのですが、先ほどのコードを動かすには参照設定が必要です。

参照設定の一覧(下の画像を参考)から次の項目(ライブラリ)にチェックを付けて「OK」ボタンをクリックします。

  1. Microsoft ActiveX Data Objects 2.8 Library(msado28.tlb)
  2. Windows Script Host Object Model(wshom.ocx)

なぜ必要かというと、Excelのマクロのコードの13行目の「ADODB.Stream」というオブジェクトが「msado28.tlb」というファイルを、14行目の「FileSystemObject」と15行目の「WshShell」というオブジェクトが「wshom.ocx」というファイルを参照するからです。

    Dim st                  As ADODB.Stream         'バイナリ データまたはテキストのストリームのインスタンス用変数
    Dim fso                 As FileSystemObject     'FileSystemObjectのインスタンス用変数
    Dim wshObj              As WshShell             'WshShellオブジェクト

この参照設定をしないと下の画像のエラーが出ますので必ず行う必要があります。

ここでは「msado28.tlb」と「wshom.ocx」とは何者かについては記事の本題から逸れてしまうので詳細は割愛しますが、マクロで「ADODB.Stream」「FileSystemObject」「WshShell」というオブジェクトを使う場合は参照設定しないと動かない、程度に思って頂ければと思います。

目次へ戻る

最後に

本記事では、複数のフォルダにある同じ名前のファイル全てを1つのフォルダにコピーする方法についてご説明しました。

ファイル名の重複を気にせずにパソコン内のファイルを1箇所に集めたい時は本記事を参考にしてみてくださいね。

Excelのスキル向上やExcelの基礎知識をしっかりと学びたいなら

Excelのスキルを習得したい、Excelの基礎知識をもっと理解したい、そう考えているなら「無期限サポート付きExcel講座【すごい改善】」がおすすめです。

Excelのスキルの基礎を身につけるなら【すごい改善】で無期限サポート付きがあるので、これで「Excelのスキルや基礎」を学ぶのにおすすめですよ。

→　受講後、何度でも無期限でメールで質問できるアフターサポートがついているExcelマスター講座はこちら



目次へ戻る

前の記事

【ExcelVBA】フォルダ内のExcelファイルにあるモジュ…

次の記事

【ExcelVBA】配列から文字列を検索する方法とは(Appl…