箸休め_9

2024年9月29日 22:45

VBAでFileを複製する

今回もご覧いただきありがとうございます。
前回の「VBAでファイル共有」の中で、同じBookを「共有するPCの台数分つくる。」と言いましたが、PCの台数が増えたり、イベントごとに参加者名簿が変わったりと、運用を繰り返す中で、対応が地味に面倒になります。
そこで、今回は複製を手処理に代わりExcelさんにお願いすることにします。

画面の例では、複製をつくる場所と、その数量を指定してVBAに依頼すると、その結果が得られる仕掛けをつくります。

この例では、10行G列にFolder名、12行G列に複製の数量を入力するようにしています。
そして、10行G列が空白のときは、自身と同じFolderに、入力が有るときはその名前で新たなFolderをつくり、その中に12行G列の数量分を複製します。

それでは、Algorithmから考えてみましょう。
今回のメインはFolderをつくることとFile(Book)をコピーすることです。

まず、Folder作成は「MkDir」（Make Directory：Directory≒Folderをつくる）を使います。
構文は、MkDir DR & Cells(10, "G")ですが、予め
DR = ThisWorkbook.Path & "¥"として「自身が居る場所」としておくと、
Cells(10, "G")に入力された文字列名のFolderを、自身が居るFolder内につくるとなります。
最後の¥は、区切り文字として必要なので忘れないように注意しましょう。

それから、ファイルコピーはそのまま「FileCopy」を使います。
構文は、FileCopy DR & Bn, DT & Btで複製元のFile（在処とファイル名）,複製先のFile（置き場とファイル名）を指定します。
DRは前述と同じく自身のPathで、DTは条件によって、新たなFolderをつくった場合は、そのFolderまでのPath。新たなFolderをつくらなかった場合は自身のPathとなります。
そして、このFileCopyを数量分繰り返します。

それでは、コーディングしながら詳細を説明します。
Procedure名を「複製」としてSub 複製()から始めます。
今回は、直下にOn Error GoTo Exを入れて、なにかしらのエラーがあったらラベルExに飛ぶようにしておきます。
ここから通常のLogicです。
DR = ThisWorkbook.Path & "¥"で自身の居場所を知るところからはじめます。
次にFn = 2を入れます。
これは、前述の説明では特に触れていませんでしたが、後述の繰り返しで必要な指標となるもので、初期値を2とします。
そして、10行G列のセルが空白でないときDRの中に指定のフォルダをつくりるために
If Cells(10, "G") <> "" Then
　MkDir DR & Cells(10, "G"): Fn = 1
End If
が入ります。
また、フォルダ作成時のFnは1としています。

ここから、Book複製です。
複写元のBook「受付_PC1.xlsm」をBnとすると
　Bn = "受付_PC1.xlsm"
複写先のフォルダをDTとすると
　DT = DR & Cells(10, "G") & "¥"
となりますが、新たにフォルダをつくった場合はそのPath(DR & Cells(10, "G"))、つくらなかった場合は、Cells(10, "G")が空白のため結果的に自身のPath（DR）となります。
複製する数量を変数Cnに受け取り、念のためにCnが空白または、2より小さいときは”NG"とします。
Cn = Cells(12, "G")
If Cn = "" Or Cn < 2 Then Cn = "NG"
これを数量分繰り返すので、繰り返しの構文により
For n = Fn To Cn
　Bt = Replace(Bn, "1", n)
　FileCopy DR & Bn, DT & Bt
Next n
となります。
Fnは初期値を2、フォルダ作成時を1としています。
どういう意図かと言うとフォルダをつくったときは、受付_PC1から複製しますが、フォルダをつくらなかった場合は、受付_PC1は既に自身のフォルダに存在しているため、複製が必要なのは受付_PC2からとなります。
したがって、状況により繰り返しの開始値(n)を変える必要があります。
人間的に考えると分かりきったことなのでしょうが、相手がExcelさんだと仕方のないことなのでご理解ください。
また、Cnは数値でなければならず、文字が入っていた場合はエラーとなりますが、冒頭の「On Error GoTo Ex」により後述のラベルExに飛ばされます。

繰り返しの内容FileCopy DR & Bn, DT & Btは、自身のFolderにある受付PC1を目的のFolder（DT)にBtの名前でCopyするための構文です。
BtをBt = Replace(Bn, "1", n)とすると、繰り返しの中でBook名「受付_PC1.xlsm」の1の部分がnに置き換えられるので１回目は「受付_PC1.xlsm」、２回目は「受付_PC2.xlsm」、３回目は・・・となります。

最後に修了メッセージを表示して
　MsgBox "　　　受付用Bookを複製しました。" _
　, 0 + 64, "受付用Book　　　　　　　　　　　　　　　　njun264
Exit subで一旦処理を終了します。

それから、エラー回避処置を組み込みます。
Exit subの次の行にラベルEx:を置くと、エラーが発生したときだけここに飛び込んできます。
ここで考えられるエラーは、Cnに文字(数値以外)が入力されたときと新たにつくるフォルダ（Cells(10, "G")の値）が既に存在しているときです。
また、万一に備えて複写元の「受付_PC1.xlsm」がない時も加えておきましょう。
このようなエラーはエラーコード（Err）で返されるので、そのコードに応じた処理をつくります。
今回はいずれの場合も、エラー表示を出して操作員に対処を委ねます。

Cnの文字はErr=13、フォルダ既存はErr=75、複写元がない時はErr=53となっているので、
If Err = 13 Then
　MsgBox "　　　数量に誤りがあります。" & Chr(13) _
　　　　& "　　　2以上の整数を入力してください。" _
　　　　, 0 + 16, "受付用PC_Setup　　　　　　　　　　　　　　　njun264"

If Err = 75 Then
　MsgBox "　　　新規Folder「" & Cells(10, "G") & "」は既に存在しています。" & Chr(13) _
　　　　& "　　　名前を変えてください。" _
　　　　, 0 + 16, "受付用PC_Setup　　　　　　　　　　　　　　　njun264"

If Err = 53 Then
　MsgBox "　　　複写元の「受付_PC1.xlsm」が見つかりません。" & Chr(13) _
　　　　& "　　　受付_PC1.xlsmを復元してください。" _
　　　　, 0 + 16, "受付用PC_Setup　　　　　　　　　　　　　　　njun264"
とすれば、操作員にエラーの状況と対処方が伝わります。

以上で初期の目標は達成しましたが、欲を出してついでにショートカットまで作ってもらうことにします。
まず、前提として「Windows Script Host Object Model」にCheck を付ける必要があります。
唐突に言われても理解できないと思いますので、以下の手順で操作してください。
VBAエディタのツールをクリックして、参照設定を選択

表示される一覧表から「Windows Script Host Object Model」を探してCheckをつけてください。

ここから、再びコーディングに戻って
Procedure名を「SCG」としてSub SCG(DT) から始めます。
　DTは前述のProcedure「複製」でつくったフォルダ名をParameterとして受け取り、処理を進めます。
Set WS = CreateObject("WScript.Shell") でWshShellオブジェクトを作成し
当該フォルダにあるBookのうち、名前にPCが含まれるものすべてにショートカットをつくります。
Buf = Dir(DT & "¥*PC*.xlsm")
Do While Buf <> ""
　SP = DT & "¥" & Replace(Buf, ”xlsm","lnk")
　With WS.CreateShortcut(SP)
　　.TargetPath = DT & Buf 'ShortcutのLink先
　　.Save 'Shortcutの保存
　End With
　Buf = Dir()
Loop
とすると、指定したすべてのBookにSPの名前のショートカットが作成されます。

すべてのショートカットをつくり終えたら
Set WS = NothingでObjectをClearして
End SubでProcedureの終わりです。
Procedure「複製」でコーディングしたNext nとMsgBoxの間に
SCG DT　を入れると、Procedure「複製」で複製したBookにショートカットをつくって、終了メッセージを表示する一連の処理が完了します。

参考までに完成形は以下のとおりです。

Sub BC()
On Error GoTo Ex

'**Default
    DR = ThisWorkbook.Path & "\"  '自身の居場所(Path)
    Fn = 2                        '複製開始指標

'** Folder作成
    If Cells(10, "G") <> "" Then          '複製場所に入力があったとき
       MkDir DR & Cells(10, "G"): Fn = 1  'Folder作成後Fnを1にする
    End If

'** Book複製
    Bn = "受付_PC1.xlsm"
    DT = DR & Cells(10, "G") & "\"   '複写先Folder(Path)

    Cn = Cells(12, "G")  '複製数量
    If Cn < 2 Or Cn = "" Then Cn = "NG"

    For n = Fn To Cn     '複製繰り返し(Folder作成時は1からその他は2から始める)

      Bt = Replace(Bn, "1", n)   '新しいBook名
      FileCopy DR & Bn, DT & Bt  '**** 複製の構文　今回のMain ****
                                 'Copy元のFile居場所&File名,Copy先のFile居場所&File名
    Next n

    SCG DT  '**** Shortcut作成Procedure **** ついでにショートカットも作る

    MsgBox "　　　受付用Bookを複製しました。" _
          , 0 + 64, "受付用Book　　　　　　　　　　　　 　　　　njun264"

Exit Sub
Ex:
    If Err = 13 Then MsgBox "　　　数量に誤りがあります。" & Chr(13) _
                          & "　　　2以上の整数を入力してください。" _
                          , 0 + 16, "受付用PC_Setup　　　　　　　　　　　　　　　　　　　njun264"

    If Err = 75 Then MsgBox "　　　新規Folder「" & Cells(10, "G") & "」は既に存在しています。" & Chr(13) _
                          & "　　　名前を変えてください。" _
                          , 0 + 16, "受付用PC_Setup　　　　　　　　　　　　　　　　　　　njun264"
    
    If Err = 53 Then MsgBox "　　　複写元の「受付_PC1.xlsm」が見つかりません。" & Chr(13) _
                          & "　　　受付_PC1.xlsmを復元してください。" _
                          , 0 + 16, "受付用PC_Setup　　　　　　　　　　　　　　　　　　　njun264"

End Sub
Sub SCG(DT) 'Shortcut作成

   '*** マクロ＞ツール＞Windows Script Host Object ModelにCheck ***
    Set WS = CreateObject("WScript.Shell")  'WshShellオブジェクトを作成

   '*** Folder内のBookを検索 ***
    Buf = Dir(DT & "\*PC*.xlsm")
    Do While Buf <> ""

       SP = DT & "\" & Replace(Buf, "xlsm", "lnk")  'Shortcut作成Folder&Shortcut名

       With WS.CreateShortcut(SP)
           .TargetPath = DT & Buf           'ShortcutのLink先
           .Save                            'Shortcutの保存
       End With

       Buf = Dir()

    Loop
    Set WS = Nothing

End Sub

実行例は以下のとおりとなります。

入力項目により、新しいFolder「研修受付」がつくられてその中に「受付PC_1」～「受付PC_5」とそれぞれのショートカットが作成されます。
このように、File(Book)の複製と、ショートカットの作り方を応用すると、手でコピペしてFileme名を変えて、これを何度か繰り返して・・・。といった煩わしさから開放されるので、是非お試しください。

今回も最後までご覧いただき、ありがとうございました。

この記事が気に入ったらサポートをしてみませんか？