2022-07-19

フォルダコピーとファイルの移動　～ ⑦ まとめ～

Excel VBA 作ってみた

頂いた問い合わせに基づき一連のマクロを作成する過程を、前回までの
都合６回にわたりご紹介してきた。今回は、そのまとめを行う。

今回の要件は、纏めると以下のとおり。
【環境】

フォルダＡ下に、フォルダＢ１，Ｂ２，・・・が存在する。
その各々に、yyyymmdd（※年月日）フォルダが一つ存在する。
さらにその下に、複数のファイルが存在する。

【要件】

フォルダＢ１，Ｂ２をループして、フォルダyyyymmddの日付と
指定日の前後関係を確認する。
例えばＢ１下のフォルダが指定日以前の場合、以下の操作を行う。
① Ｂ１の親フォルダＡを、あらかじめ指定した先に（なければ）作成する。
② Ｂ１を含む全てを、①で作成したフォルダ下に移動させる。
③ 移動後に、移動したファイルを一つずつ圧縮する（zip）。
④ 圧縮された元のファイルは削除する。
2. の移動記録を出力する。
処理の中断機能を設ける。ただし「非常停止」ではなく、実行中の
最小ループ（多重ループの一番内側）を一回終えてからの終了とする。

各回のまとめが ↓ こちら。
infoment.hatenablog.com
infoment.hatenablog.com
infoment.hatenablog.com
infoment.hatenablog.com
infoment.hatenablog.com
infoment.hatenablog.com

必要な参照設定は ↓ の二つ。

Microsoft Scripting Runtime
Windwos Script Host Object Library

遅延バインディングとする場合は、マクロの修正が必要。

その他

移動ログを書き出すシートのオブジェクト名は「LogSheet」とする。
移動ボタンはActiveXコントロールで作成。オブジェクト名は「cbMove」。
中断ボタンもActiveXコントロールで作成。オブジェクト名は「cbStop」。
LogSheet内に、記録用テーブルを一つ準備。ラベル名は各回を参照のこと。
ラベルの並び順や追加は任意に変更可。

今回作成したコードは、以下のとおり。
＜LogSheetに作成（シートモジュール）＞

Option Explicit

Private Sub cbMove_Click()
    Dim SpecifiedDate As Variant
        SpecifiedDate = InputBox("基準日を入力してください。", _
                                 "基準日入力", Date)
        If Not IsDate(SpecifiedDate) Then
            MsgBox "日付以外が入力されたため、処理を中断します。"
            Exit Sub
        End If
        
        ' 中断用フラグ初期化。
        StopFlag = False
    
    ' フォルダの移動。
    Call MoveFolders(CDate(SpecifiedDate))
    ' 圧縮と削除。
    Call ZipAndSourceDelete
End Sub

Private Sub cbStop_Click()
    StopFlag = True
End Sub

＜標準モジュールに作成＞

Option Explicit

' コピー元の親フォルダ。
Const SrcParentFolderPath As String = "C:\Temp\コピー元"
' コピー先の親フォルダ。
Const DstParentFolderPath As String = "C:\Temp\コピー先"
' FileSystemObject
Dim FSO As New Scripting.FileSystemObject
' 中断用フラグ。
Public StopFlag As Boolean

' 指定フォルダ下のファイルパスを全て取得。
Function FileList(folder_path As String) As Variant
    FileList = Filter(Split(CreateObject("wscript.shell").Exec("cmd /c Dir """ & folder_path & """ /b /s /a-d").StdOut.ReadAll, vbCrLf), ".")
End Function

Function IsMovable(folder_name As String, specified_date As Date) As Boolean
    Dim TargetDate As Date
        ' ８桁でない場合、引数に誤りあり。
        If Len(folder_name) <> 8 Then
            Exit Function
        End If
        ' ８桁の数字を日付に変換。
        TargetDate = Format(folder_name, "0000/00/00")
        ' 指定日以前であればTrue。
        IsMovable = (TargetDate < specified_date)
End Function

Function MoveTargetFolder(folder_a As String, folder_b As String, _
                          ByRef before_list As Variant, _
                          ByRef after_list As Variant) As Boolean
        On Error GoTo er:
    
    ' パス用配列の初期化。
        before_list = Array()
        after_list = Array()
    
    ' 移動する部分のフォルダパス。
    Dim MovePartName As String
        MovePartName = folder_a & "\" & folder_b

    ' 移動元のパス。
    Dim SrcFolderPath As String
        SrcFolderPath = FSO.BuildPath(SrcParentFolderPath, MovePartName)
    
    ' 移動先のパス。
    Dim DstFolderPath As String
        DstFolderPath = FSO.BuildPath(DstParentFolderPath, MovePartName)
    
    ' 階層Ａの移動先フォルダフルパス。
    Dim DstFolderAPath As String
        DstFolderAPath = FSO.BuildPath(DstParentFolderPath, folder_a)
    
    ' 移動先のフォルダ有無確認｡なければ作成する｡
        If Not FSO.FolderExists(DstFolderAPath) Then
            MkDir DstFolderAPath
        End If
    
    ' 移動前のパス取得。
        before_list = FileList(SrcFolderPath)
    
    ' フォルダ移動。
        FSO.MoveFolder SrcFolderPath, DstFolderPath
    
    ' 移動成功。
        MoveTargetFolder = True
    
    ' 移動後のパス取得。
        after_list = FileList(DstFolderPath)
        Exit Function
        
er:
    ' 移動失敗。
        MoveTargetFolder = False
End Function

Sub MoveFolders(specified_date As Date)
    ' 階層Ａのフォルダループ用。
    Dim FolderA As Scripting.Folder
    ' 階層Ｂのフォルダループ用。
    Dim FolderB As Scripting.Folder
    ' 階層Ｃのフォルダループ用。
    Dim FolderC As Scripting.Folder
    ' 移動前リスト。
    Dim BeforeList As Variant
    ' 移動後リスト。
    Dim AfterList As Variant
    ' 記録用テーブル。
    Dim Tb As ListObject
    Set Tb = LogSheet.ListObjects(1)
  
        For Each FolderA In FSO.GetFolder(SrcParentFolderPath).SubFolders
            For Each FolderB In FSO.GetFolder(FolderA).SubFolders
                For Each FolderC In FSO.GetFolder(FolderB).SubFolders
                    If IsMovable(FolderC.Name, specified_date) Then
                        MoveTargetFolder FolderA.Name, FolderB.Name, _
                                         BeforeList, AfterList
                                       
                        ' 中断ボタンの押下検出用。
                        Application.Wait [Now()+"00:00:02"]
                        
                        ' 移動記録。
                        With Tb.ListRows.Add
                            .Range(2).Resize(UBound(BeforeList) + 1) = _
                                WorksheetFunction.Transpose(BeforeList)
                            If UBound(AfterList) <> -1 Then
                                .Range(3).Resize(UBound(AfterList) + 1) = _
                                    WorksheetFunction.Transpose(AfterList)
                            End If
                            .Range(5).Resize(UBound(BeforeList) + 1) = Now
                        End With
                        
                        ' 中断ボタンが押された時の処理。
                        DoEvents
                        If StopFlag Then
                            GoTo StopTrap:
                        End If
                            
                    End If
                Next
            Next
        Next
        
        Exit Sub
        
StopTrap:
    MsgBox "処理が中断されました。"
        
End Sub

Function Zip(source_path As String, _
             destination_path As String, _
    Optional source_del_flag As Boolean = True) As Boolean
    
    ' 参照設定：Windows Script Host Object Model
    Dim WshShell As IWshRuntimeLibrary.WshShell
    Set WshShell = New IWshRuntimeLibrary.WshShell
    Dim WshExec As IWshRuntimeLibrary.WshExec
    Dim Cmd As String
    
        ' 元データ（フォルダまたはファイル）の存在確認。
        If Not FSO.FileExists(source_path) And _
           Not FSO.FolderExists(source_path) Then
            Exit Function
        ' スペースがある場合も圧縮不可。
        ElseIf InStr(source_path, " ") <> 0 Then
            Exit Function
        End If
        
        ' 圧縮用コマンド作成。既に存在する場合は上書きする（-Force）。
        Cmd = "Compress-Archive -Path " & source_path & _
              " -DestinationPath " & destination_path & " -Force"
    
    ' 圧縮実行。
    Set WshExec = WshShell.Exec( _
        "powershell -NoLogo -ExecutionPolicy RemoteSigned -Command " & Cmd)
    
        ' 圧縮失敗。
        If WshExec.Status = WshFailed Then Exit Function
    
        ' 圧縮完了まで待機。
        Do While WshExec.Status = WshRunning
            DoEvents
        Loop
        
        ' 圧縮前のデータを削除。
        If source_del_flag Then
            Kill source_path
        End If
    
        Zip = True
End Function

Sub ZipAndSourceDelete()
    ' 記録用テーブル。
    Dim Tb As ListObject
    Set Tb = LogSheet.ListObjects(1)
    
    ' 移動元パス配列。
    Dim SrcArray As Variant
        SrcArray = Tb.ListColumns("移動先パス").DataBodyRange
    
    ' 備考出力先。
    Dim NoteArray As Variant
        NoteArray = Tb.ListColumns("備考").DataBodyRange
    
    Dim i As Long
    Dim TempArray As Variant
    Dim DestinationPath As String
        For i = 1 To UBound(SrcArray)
            ' ファイルの存在確認。
            If Not FSO.FileExists(SrcArray(i, 1)) Then
            ' 既に圧縮されているか否かの確認。
            ElseIf StrConv(Right(SrcArray(i, 1), 4), _
                           vbNarrow + vbLowerCase) = ".zip" Then
            Else
                ' 拡張子を除去するため、一旦"."で分割。
                TempArray = Split(SrcArray(i, 1), ".")
                ' 分割結果の要素数を一つ減らすことで、拡張子を除去。
                ReDim Preserve TempArray(UBound(TempArray) - 1)
                ' "."で結合して末尾に".zip"を追加し、圧縮後バスを作成。
                DestinationPath = Join(TempArray, ".") & ".zip"
                
                If Zip(CStr(SrcArray(i, 1)), DestinationPath) Then
                    '圧縮が成功したならば、圧縮後のパスに置き換える。
                    SrcArray(i, 1) = DestinationPath
                    NoteArray(i, 1) = "圧縮成功"
                Else
                    NoteArray(i, 1) = "圧縮失敗"
                End If
            End If
        Next
        
        ' 結果の出力。
        Tb.ListColumns("移動先パス").DataBodyRange = SrcArray
        Tb.ListColumns("備考").DataBodyRange = NoteArray
End Sub

＜注意＞（免責事項）
今回は初期設定で、最終的にファイルの削除を行っている。従ってこれを参照し、実務や何某かで実行される場合は、意図せずデータが失われないよう充分に注意してほしい。
※その辺り、こちらでは責任を負いかねますので、充分にテストしたうえで、自己責任の範囲で使用願います。

＜感想＞
ファイルの圧縮操作部分は、今回初めて学んだことが多かったです。
とても勉強になりました。

以上、ご参考まで。

2022-07-18

フォルダコピーとファイルの移動　～ ⑥ 移動したファイルの圧縮～

Excel VBA 作ってみた

先日は、フォルダの移動中に中断処理を追加してみた。
infoment.hatenablog.com
今日も、昨日の続きから。

リクエストの最後の条件は、以下のとおり。

移動先で、ファイルを圧縮したい。
圧縮は、ファイル単位で行いたい。
圧縮後、圧縮前ファイルは削除したい。

そこでまず、圧縮する関数を作成してみた。作成に際しては、こちらのサイトを
丸々参考にさせていただいた。ありがとうございます。
vbabeginner.net

Function Zip(source_path As String, _
             destination_path As String, _
    Optional source_del_flag As Boolean = True) As Boolean
    
    ' 参照設定：Windows Script Host Object Model
    Dim WshShell As IWshRuntimeLibrary.WshShell
    Set WshShell = New IWshRuntimeLibrary.WshShell
    Dim WshExec As IWshRuntimeLibrary.WshExec
    Dim Cmd As String
    
        ' 元データ（フォルダまたはファイル）の存在確認。
        If Not FSO.FileExists(source_path) And _
           Not FSO.FolderExists(source_path) Then
            Exit Function
        ' スペースがある場合も圧縮不可。
        ElseIf InStr(source_path, " ") <> 0 Then
            Exit Function
        End If
        
        ' 圧縮用コマンド作成。既に存在する場合は上書きする（-Force）。
        Cmd = "Compress-Archive -Path " & source_path & _
              " -DestinationPath " & destination_path & " -Force"
    
    ' 圧縮実行。
    Set WshExec = WshShell.Exec( _
        "powershell -NoLogo -ExecutionPolicy RemoteSigned -Command " & Cmd)
    
        ' 圧縮失敗。
        If WshExec.Status = WshFailed Then Exit Function
    
        ' 圧縮完了まで待機。
        Do While WshExec.Status = WshRunning
            DoEvents
        Loop
        
        ' 圧縮前のデータを削除。
        If source_del_flag Then
            Kill source_path
        End If
    
        Zip = True
End Function

圧縮は、あとで無くしたくなるかもしれない。そこで一旦移動ののち、
圧縮する別のサブプロシージャを実行することとした。

Sub ZipAndSourceDelete()
    ' 記録用テーブル。
    Dim Tb As ListObject
    Set Tb = LogSheet.ListObjects(1)
    
    ' 移動元パス配列。
    Dim SrcArray As Variant
        SrcArray = Tb.ListColumns("移動先パス").DataBodyRange
    
    ' 備考出力先。
    Dim NoteArray As Variant
        NoteArray = Tb.ListColumns("備考").DataBodyRange
    
    Dim i As Long
    Dim TempArray As Variant
    Dim DestinationPath As String
        For i = 1 To UBound(SrcArray)
            ' ファイルの存在確認。
            If Not FSO.FileExists(SrcArray(i, 1)) Then
            ' 既に圧縮されているか否かの確認。
            ElseIf StrConv(Right(SrcArray(i, 1), 4), _
                           vbNarrow + vbLowerCase) = ".zip" Then
            Else
                ' 拡張子を除去するため、一旦"."で分割。
                TempArray = Split(SrcArray(i, 1), ".")
                ' 分割結果の要素数を一つ減らすことで、拡張子を除去。
                ReDim Preserve TempArray(UBound(TempArray) - 1)
                ' "."で結合して末尾に".zip"を追加し、圧縮後バスを作成。
                DestinationPath = Join(TempArray, ".") & ".zip"
                
                If Zip(CStr(SrcArray(i, 1)), DestinationPath) Then
                    '圧縮が成功したならば、圧縮後のパスに置き換える。
                    SrcArray(i, 1) = DestinationPath
                    NoteArray(i, 1) = "圧縮成功"
                Else
                    NoteArray(i, 1) = "圧縮失敗"
                End If
            End If
        Next
        
        ' 結果の出力。
        Tb.ListColumns("移動先パス").DataBodyRange = SrcArray
        Tb.ListColumns("備考").DataBodyRange = NoteArray
End Sub

昨日作成した「cbDoMove」ボタンは、「Do」は要らないかなと思い
「cbMove」に名前を変更した。そのうえで、圧縮処理を追加したのが
こちら。

Private Sub cbMove_Click()
    Dim SpecifiedDate As Variant
        SpecifiedDate = InputBox("基準日を入力してください。", _
                                 "基準日入力", Date)
        If Not IsDate(SpecifiedDate) Then
            MsgBox "日付以外が入力されたため、処理を中断します。"
            Exit Sub
        End If
        
        ' 中断用フラグ初期化。
        StopFlag = False
    
    ' フォルダの移動。
    Call MoveFolders(CDate(SpecifiedDate))
    ' 圧縮と削除。
    Call ZipAndSourceDelete
End Sub

それではテストしてみよう。移動ボタンを押した結果がこちら。

元ファイルが消えて、圧縮ファイルだけ残すことができた。

次回、まとめページを作成して終了です。

参考まで。

2022-07-16

フォルダコピーとファイルの移動　～ ⑤ 処理の中断～

Excel VBA 作ってみた

先日は、フォルダの移動結果をシートに入力するところまでを作成した。
infoment.hatenablog.com
今日も、先日の続きから。

リクエストによれば、処理の中断処理が必要だ。しかも非常停止ではなく、
繰返しを抜ける処理だ（サイクル停止）。そこで、シートに中断ボタンを
設けることにした。ついでに、処理を開始する移動ボタンも準備しよう。

二つのボタンは共に、ActiveXコントロールのCommandButtonとした。
オブジェクト名：

移動：cbDoMove
中断：cbStop

中断ボタンが押されたことを検知させるために、標準モジュールに
Public変数を一つ設ける。

' 中断用フラグ。
Public StopFlag As Boolean

各ボタンのクリックイベントは、以下のとおり。
※シートモジュールに設置。

Private Sub cbDoMove_Click()
    Dim SpecifiedDate As Variant
        SpecifiedDate = InputBox("基準日を入力してください。", _
                                 "基準日入力", Date)
        If Not IsDate(SpecifiedDate) Then
            MsgBox "日付以外が入力されたため、処理を中断します。"
            Exit Sub
        End If
        
        ' 中断用フラグ初期化。
        StopFlag = False
        
    Call MoveFolders(CDate(SpecifiedDate))
End Sub

Private Sub cbStop_Click()
    StopFlag = True
End Sub

フォルダおよびファイル移動用プロシージャに、中断処理を追加。

Sub MoveFolders(specified_date As Date)
    ' 階層Ａのフォルダループ用。
    Dim FolderA As Scripting.Folder
    ' 階層Ｂのフォルダループ用。
    Dim FolderB As Scripting.Folder
    ' 階層Ｃのフォルダループ用。
    Dim FolderC As Scripting.Folder
    ' 移動前リスト。
    Dim BeforeList As Variant
    ' 移動後リスト。
    Dim AfterList As Variant
    ' 記録用テーブル。
    Dim Tb As ListObject
    Set Tb = LogSheet.ListObjects(1)
  
        For Each FolderA In FSO.GetFolder(SrcParentFolderPath).SubFolders
            For Each FolderB In FSO.GetFolder(FolderA).SubFolders
                For Each FolderC In FSO.GetFolder(FolderB).SubFolders
                    If IsMovable(FolderC.Name, specified_date) Then
                        MoveTargetFolder FolderA.Name, FolderB.Name, _
                                         BeforeList, AfterList
                                       
                        ' 中断ボタンの押下検出用。
                        Application.Wait [Now()+"00:00:02"]
                        
                        ' 移動記録。
                        With Tb.ListRows.Add
                            .Range(2).Resize(UBound(BeforeList) + 1) = _
                                WorksheetFunction.Transpose(BeforeList)
                            If UBound(AfterList) <> -1 Then
                                .Range(3).Resize(UBound(AfterList) + 1) = _
                                    WorksheetFunction.Transpose(AfterList)
                            End If
                            .Range(5).Resize(UBound(BeforeList) + 1) = Now
                        End With
                        
                        ' 中断ボタンが押された時の処理。
                        DoEvents
                        If StopFlag Then
                            GoTo StopTrap:
                        End If
                            
                    End If
                Next
            Next
        Next
        
        Exit Sub
        
StopTrap:
    MsgBox "処理が中断されました。"
        
End Sub

中断ボタンを押しても、移動規模によっては、あっという間に処理が
完了してしまう。そこで、移動毎に２秒の待ち時間を設けた。実際の
運用で何秒にするかは、使う方のお好みで決めていただこう。

それではテストしてみよう。移動ボタンを押して、すぐに中断ボタンを
押した結果がこちら。

それでは次回、最終回（仮）に続きます。

参考まで。

2022-07-14

フォルダコピーとファイルの移動　～ ④ ログを出力～

Excel VBA 作ってみた

昨日は、あるフォルダを別のフォルダへ移動する操作を、連続で行うところまでを作成した。
infoment.hatenablog.com
今日も、昨日の続きから。

うっかりしてた。移動の成否と、移動前後のフォルダパスを記録しなければ
ならなかった。記録用ログファイルは、所定のテキストファイルを準備して
書き出すなどの方法がある。しかし今回は、マクロで操作しているのだから
マクロブックに書き出すことにした。

シートのオブジェクト名は、「LogSheet」とした。

まず移動したファイルパスの取得だが、これは以前紹介した↓を再利用する。

' 指定フォルダ下のファイルパスを全て取得。
Function FileList(folder_path As String) As Variant
    FileList = Filter(Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & folder_path & """ /b /s /a-d").StdOut.ReadAll, vbCrLf), ".")
End Function

次いで、昨日作成したサブプロシージャ：MoveTargetFolderを、名前を
そのままにファンクションプロシージャにした。戻り値はBooleanとし、
移動がうまくいけばTrueを、駄目ならFalseを返す。

またその他、移動前後のパスを返したい。返したいものが複数出てきて
どうしようかと悩んだが、自主禁断のByRefを使用することとした。

Function MoveTargetFolder(folder_a As String, folder_b As String, _
                          ByRef before_list As Variant, _
                          ByRef after_list As Variant) As Boolean
        On Error GoTo er:
    
    ' パス用配列の初期化。
        before_list = Array()
        after_list = Array()
    
    ' 移動する部分のフォルダパス。
    Dim MovePartName As String
        MovePartName = folder_a & "\" & folder_b

    ' 移動元のパス。
    Dim SrcFolderPath As String
        SrcFolderPath = FSO.BuildPath(SrcParentFolderPath, MovePartName)
    
    ' 移動先のパス。
    Dim DstFolderPath As String
        DstFolderPath = FSO.BuildPath(DstParentFolderPath, MovePartName)
    
    ' 階層Ａの移動先フォルダフルパス。
    Dim DstFolderAPath As String
        DstFolderAPath = FSO.BuildPath(DstParentFolderPath, folder_a)
    
    ' 移動先のフォルダ有無確認｡なければ作成する｡
        If Not FSO.FolderExists(DstFolderAPath) Then
            MkDir DstFolderAPath
        End If
    
    ' 移動前のパス取得。
        before_list = FileList(SrcFolderPath)
    
    ' フォルダ移動。
        FSO.MoveFolder SrcFolderPath, DstFolderPath
    
    ' 移動成功。
        MoveTargetFolder = True
    
    ' 移動後のパス取得。
        after_list = FileList(DstFolderPath)
        Exit Function
        
er:
    ' 移動失敗。
        MoveTargetFolder = False
End Function

ここまで作って、気が付いた。戻り値がTrueでもFalseでも記録は必要な訳で。
条件分岐を設けるのも煩雑なので、せっかくの戻り値は使わず、結果をベタと
貼り付けることにした。

Sub MoveFolders(specified_date As Date)
    ' 階層Ａのフォルダループ用。
    Dim FolderA As Scripting.Folder
    ' 階層Ｂのフォルダループ用。
    Dim FolderB As Scripting.Folder
    ' 階層Ｃのフォルダループ用。
    Dim FolderC As Scripting.Folder
    ' 移動前リスト。
    Dim BeforeList As Variant
    ' 移動後リスト。
    Dim AfterList As Variant
    ' 記録用テーブル。
    Dim Tb As ListObject
    Set Tb = LogSheet.ListObjects(1)
    
        For Each FolderA In FSO.GetFolder(SrcParentFolderPath).SubFolders
            For Each FolderB In FSO.GetFolder(FolderA).SubFolders
                For Each FolderC In FSO.GetFolder(FolderB).SubFolders
                    If IsMovable(FolderC.Name, specified_date) Then
                        MoveTargetFolder FolderA.Name, FolderB.Name, _
                                         BeforeList, AfterList
                        
                        ' 移動記録。
                        With Tb.ListRows.Add
                            .Range(2).Resize(UBound(BeforeList) + 1) = _
                                WorksheetFunction.Transpose(BeforeList)
                            If UBound(AfterList) <> -1 Then
                                .Range(3).Resize(UBound(AfterList) + 1) = _
                                    WorksheetFunction.Transpose(AfterList)
                            End If
                            .Range(5).Resize(UBound(BeforeList) + 1) = Now
                        End With
                            
                    End If
                Next
            Next
        Next
End Sub

それでは昨日と同様、↓ こちらで試してみよう。

Sub test()
    MoveFolders #8/1/2022#
End Sub

結果、このように出力された。一応、成功したようだ。

ちなみに、何らかの理由により移動が失敗すると、↓ の結果となる。

成功／失敗の表記は関数で対応。

No.列も、いつもの関数で対応。

あと二回ぐらい続きます。

参考まで。

2022-07-13

フォルダコピーとファイルの移動　～ ③ 連続で処理～

Excel VBA 作ってみた

昨日は、あるフォルダを別のフォルダへ移動するところまで作成した。
infoment.hatenablog.com
今日も、昨日の続きから。

今回は、指定フォルダ下にある判定対象フォルダを、連続で処理してみる。
各フォルダの名前を取得して判定などに使用するわけで、検討の過程で
先日作成したIsMovable関数を、もう少しだけ簡素化してみた。

Option Explicit

' コピー元の親フォルダ。
Const SrcParentFolderPath As String = "C:\Temp\コピー元"
' コピー先の親フォルダ。
Const DstParentFolderPath As String = "C:\Temp\コピー先"
' FileSystemObject
Dim FSO As New Scripting.FileSystemObject

Function IsMovable(folder_name As String, specified_date As Date) As Boolean
    Dim TargetDate As Date
        ' ８桁でない場合、引数に誤りあり。
        If Len(folder_name) <> 8 Then
            Exit Function
        End If
        ' ８桁の数字を日付に変換。
        TargetDate = Format(folder_name, "0000/00/00")
        ' 指定日以前であればTrue。
        IsMovable = (TargetDate < specified_date)
End Function

単一処理の部分がこちら（昨日分を再掲）。

Sub MoveTargetFolder(folder_a As String, folder_b As String)
    ' 移動する部分のフォルダパス。
    Dim MovePartName As String
        MovePartName = folder_a & "\" & folder_b

    ' 移動元のパス。
    Dim SrcFolderPath As String
        SrcFolderPath = FSO.BuildPath(SrcParentFolderPath, MovePartName)
    
    ' 移動先のパス。
    Dim DstFolderPath As String
        DstFolderPath = FSO.BuildPath(DstParentFolderPath, MovePartName)
    
    ' 階層Ａの移動先フォルダフルパス。
    Dim DstFolderAPath As String
        DstFolderAPath = FSO.BuildPath(DstParentFolderPath, folder_a)
    
    ' 移動先のフォルダ有無確認｡なければ作成する｡
        If Not FSO.FolderExists(DstFolderAPath) Then
            MkDir DstFolderAPath
        End If
    
    ' フォルダ移動。
        FSO.MoveFolder SrcFolderPath, DstFolderPath
End Sub

そして、これをループさせて連続処理するのがこちら。指定日は引数で
与えることとした。

Sub MoveFolders(specified_date As Date)
    ' 階層Ａのフォルダループ用。
    Dim FolderA As Scripting.Folder
    ' 階層Ｂのフォルダループ用。
    Dim FolderB As Scripting.Folder
    ' 階層Ｃのフォルダループ用。
    Dim FolderC As Scripting.Folder
    
        For Each FolderA In FSO.GetFolder(SrcParentFolderPath).SubFolders
            For Each FolderB In FSO.GetFolder(FolderA).SubFolders
                For Each FolderC In FSO.GetFolder(FolderB).SubFolders
                    If IsMovable(FolderC.Name, specified_date) Then
                        MoveTargetFolder FolderA.Name, FolderB.Name
                    End If
                Next
            Next
        Next
End Sub

それでは、早速テストしてみよう。

Sub test()
    MoveFolders #8/1/2022#
End Sub

想定では8/1より前の日付名を持つＢ１，Ｂ２のみ、コピー先へ移動するはず。

上手くいったようだ。

明日に続きます。

参考まで。

2022-07-12

フォルダコピーとファイルの移動　～ ② 移動先のフォルダ作成～

Excel VBA 作ってみた

昨日は、いただいた問い合わせ内容を整理しながら、テスト環境を作成してみた。
infoment.hatenablog.com
今日も、昨日の続きから。

昨日の記事を書いた後、質問された方から幾つか条件の訂正連絡があった。

フォルダの移動先に、フォルダＡは最初からは存在していない。
フォルダＢ１，Ｂ２・・・は、作成したフォルダＡにコピーののち、元を削除したい。
フォルダＢ１，Ｂ２・・・をループで処理したい。

ということで実際は、↓ 雲マークのフォルダＡが存在しない場合は作る、という
修正のみでよさそうだ。

処理条件を眺めてみると、各Ａの中の各Ｂをそれぞれ確認する必要があるので、
二重ループになりそうだ。

こんなとき、様々なアプローチがあると思うが、今回まず小さな範囲で処理を
作り、それをループさせる方式でやってみる。

ということで、「C:\Temp\コピー元\Ａ\Ｂ1\20220701」を、コピー先に移動
させてみよう。

フォルダパスから、「Ａ」というフォルダ名を取得する。
取得した名称から、「C:\Temp\コピー元\Ａ」というパスを作成する。
作成したフォルダパスが存在するか確認。存在しない場合は作成する。
作成した先に、「Ｂ1」を移動させる。

Sub Test()
    ' 階層Ａのフォルダ名。
    Dim FolderA As String
        FolderA = "Ａ"

    ' 階層Ｂのフォルダ名。
    Dim FolderB As String
        FolderB = "Ｂ1"
        
    ' 移動する部分のフォルダパス。
    Dim MovePartName As String
        MovePartName = "Ａ\Ｂ1"

    ' 移動元のパス。
    Dim SrcFolderPath As String
        SrcFolderPath = FSO.BuildPath(SrcParentFolderPath, MovePartName)
    
    ' 移動先のパス。
    Dim DstFolderPath As String
        DstFolderPath = FSO.BuildPath(DstParentFolderPath, MovePartName)
    
    ' 階層Ａの移動先フォルダパス。
    Dim DstFolderAPath As String
        DstFolderAPath = FSO.BuildPath(DstParentFolderPath, FolderA)
    
    ' 移動先のフォルダ有無確認｡なければ作成する｡
        If Not FSO.FolderExists(DstFolderAPath) Then
            MkDir DstFolderAPath
        End If
    
    ' フォルダ移動。
        FSO.MoveFolder SrcFolderPath, DstFolderPath
End Sub

実行してみると、コピー先にフォルダＡが作成され、その下にＢ１以降の
フォルダおよびファイルが全て移動していることが分かる。

実際はループでの処理となるので、FolderAおよびBは引数として与えた
方がよさそうだ。

Sub MoveTargetFolder(folder_a As String, folder_b As String)
    ' 移動する部分のフォルダパス。
    Dim MovePartName As String
        MovePartName = folder_a & "\" & folder_b

    ' 移動元のパス。
    Dim SrcFolderPath As String
        SrcFolderPath = FSO.BuildPath(SrcParentFolderPath, MovePartName)
    
    ' 移動先のパス。
    Dim DstFolderPath As String
        DstFolderPath = FSO.BuildPath(DstParentFolderPath, MovePartName)
    
    ' 階層Ａの移動先フォルダパス。
    Dim DstFolderAPath As String
        DstFolderAPath = FSO.BuildPath(DstParentFolderPath, folder_a)
    
    ' 移動先のフォルダ有無確認｡なければ作成する｡
        If Not FSO.FolderExists(DstFolderAPath) Then
            MkDir DstFolderAPath
        End If
    
    ' フォルダ移動。
        FSO.MoveFolder SrcFolderPath, DstFolderPath
End Sub

↓ こちらでテストしたところ、先程と同じ結果を得ることができた。

Sub test()
    MoveTargetFolder "Ａ", "Ｂ1"
End Sub

次回はこれを、ループに組み込みます。

参考まで。

2022-07-11

フォルダコピーとファイルの移動　～ ① 必要な条件を書き出してみる～

Excel VBA 作ってみた

先日、このような問い合わせをいただいた。

そこで、私の場合どのようにゴールするか、検討過程も含めて紹介しようと思う。
※現時点でこの課題は、未解決の状態です（超見切り発車）。

あるフォルダから、別のフォルダへファイルを移動したい。また、移動先の
フォルダ名は、もと居たフォルダ名をコピーして作りたい。

ということで、こんな感じで C:\ 直下にテスト環境を作成してみた。

Ｂを含め全て移動させたいということは、Ｂ直下に存在する「yyyymmdd」形式の
フォルダは一つしか存在してはならない。なぜなら複数存在した場合、条件に合致
しないフォルダまで一括で移動させてしまうことになるから。

そのうえで、例えば20220701フォルダが条件に合致するならば、「コピー先」に
Ａを作成してから、Ｂごと「コピー元」から移動させる。

さて、ここからが試案のしどころ。まず「変わらないもの」は何かと考えると、
それは「コピー元」「コピー先」のパス情報だ。ならば、これは定数としよう。

FileSystemObjectを使用したいので、参照設定でMicrosoft Scripting Runtimeに
チェックを入れておく。

今回はナマクラして、モジュールレベル変数で宣言してしまおうか。

' コピー元の親フォルダ。
Const SrcParentFolderPath As String = "C:\Temp\コピー元"
' コピー先の親フォルダ。
Const DstParentFolderPath As String = "C:\Temp\コピー先"
' FileSystemObject
Dim FSO As New Scripting.FileSystemObject

次に、「yyyymmdd」までのパス情報が、移動対象か否かを判別する関数を
作ってみよう。

Function IsMovable(folder_path As String, specified_date As Date) As Boolean
    Dim TargetNumber As Variant
        TargetNumber = Right(folder_path, 8)
        
        ' フォルダ名が数字８桁でない場合、引数に誤りあり。
        If Not IsNumeric(TargetNumber) Then Exit Function
        
    Dim TargetDate As Date
        ' ８桁の数字を日付に変換。
        TargetDate = Format(Right(folder_path, 8), "0000/00/00")
        
        ' 指定日以前であればTrue。
        IsMovable = (TargetDate < specified_date)
End Function

実際に試してみると、指定日が当日までは移動不可で、翌日以降ならば
移動可となった。

夜も更けてきたので、今日はここまで。明日に続きます。

参考まで。