loader image

VBA ファイルサイズを参照しサイズが均等になるようにフォルダ分け

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

コメント

タイトルとURLをコピーしました