Sub ボタン1_Click() Dim Folder As String Dim Size As Long Dim Size2 As Long Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim Files Dim F(50) As String Dim i As Integer Dim FoundCell As Range 'バッチ Dim obj As WshShell Dim btFile '---------------------------本番かテストか--------------------------------- 'バッチ本番 btFile = "" 'バッチテスト 'btFile = "" '本番フォルダ Folder = "" 'テストフォルダ 'Folder = "" '---------------------------------------------------------------------------- '作業対象フォルダがあれば実行 If Dir(Folder , vbDirectory) <> "" Then '必要フォルダがなければ作成 If Dir(Folder & "対象1", vbDirectory) = "" And Dir(Folder & "対象2", vbDirectory) = "" And Dir(Folder & "対象3", vbDirectory) = "" Then MkDir Folder & "対象1" MkDir Folder & "対象2" MkDir Folder & "対象3" End If '----ファイルサイズを参照しフォルダ分け(手順No.6)---- '対象フォルダの全ファイルの合計サイズを参照 Size = fso.GetFolder(Folder & "対象").Size / 3 '対象ファイル洗い出し i = 0 Set Files = fso.GetFolder(Folder & "対象").Files For Each file In Files F(i) = file i = i + 1 Next file i = 0 Size2 = 0 '職員(対象)1にコピー Do While Size > Size2 And F(i) <> "" FileCopy F(i), Folder & "対象1\" Size2 = fso.GetFolder(Folder & "対象1").Size i = i + 1 Loop Size2 = 0 '職員(対象)2にコピー Do While Size > Size2 And F(i) <> "" FileCopy F(i), Folder & "対象2\" & Right(F(i), Len(F(i)) - InStr(F(i), "職員") + 1) Size2 = fso.GetFolder(Folder & "対象2").Size i = i + 1 Loop '残りを職員(対象)3にコピー Do While F(i) <> "" FileCopy F(i), Folder & "対象3\" i = i + 1 Loop 'バッチでCSV結合 Set obj = New WshShell Call obj.Run(btFile, WaitOnReturn:=True) '後片付け Set fso = Nothing Set obj = Nothing 'Set wsh = Nothing '正常終了のログ表示 MsgBox ("正常終了しました。No.31から対応お願いします。") Else MsgBox (Folder & "に抽出元フォルダがありませんので終了します。") End If End Sub
コメント