Excelで一定のファイルを各フォルダへコピーするマクロ

経緯と概要

　ある業務のスタート時に、一定のファイルを各フォルダ毎に用意し、そのファイル名を変更するといった事があります。以前は、フォルダに先にファイルをコピーし、各フォルダにてファイル名を変更するといった事を行っており、大変手間がかかっていました。

　それから、一定のファイルを一括でファイル名の変更をしていましたが、それでも各フォルダにファイルをコピーする手間がありました。

　今回は、Excelにて、フォルダにある一定のファイルを各フォルダに振り分けてコピーするマクロです。これまでのようにフォルダを開いたり閉じたりすることや、フォルダ毎にファイルを選ぶ必要がなくなり、業務効率が向上しました。

マクロの設定の説明

Functionの関数の引数は3つ

1. フォルダの判定のキーワード（このマクロでは　コピー先に振り分けれるように　契約書用　申請用　図面用　と入力しています。判定はB列の4行目から行っています。）
2. 元のフォルダパスのセルのアドレスです。（このマクロでは　D1に元のファイルのアドレスをいれています。） 
3. コピー先のフォルダパスのセルのアドレスです。（このマクロでは　D3　J3　P3に各コピー先のアドレスを入力しています。）

マクロのデータについて

• A列4行目からB列27列目まで入っています。 
• A列はD1にあるフォルダパスのファイル名を入力しています。
• B列はフォルダの振り分け先判定用です。 
• 上書きの警告を表示するようにしていますが、「いいえ」を選択すると、それ以後の処理も止まります。

下記　画像のような状態にしています。

感想

今回のマクロもボタンで登録して行っているため、大変便利になりました。

（別のファイル名の一括変更のマクロと組み合わせているので、更に楽になっています）

コードも数行ですので、編集しやすいと思います。

以下コード

Function Fcopy(kyw As String, oldPathAdrs As String, newPathAdrs As String) As String For i = 4 To 27 oldPath = Range(oldPathAdrs).Value & "\" & Cells(i, 1).Value newPath = Range(newPathAdrs).Value & "\" & Cells(i, 1).Value If Cells(i, 2).Value = kyw Then If Dir(newPath) <> "" Then ret = MsgBox("同名のファイルが存在します。" & vbCrLf & _ newPath & vbCrLf & _ "上書きしますか？", vbYesNo) If ret = vbNo Then Exit For End If FileCopy oldPath, newPath End If Next MsgBox (kyw & "をコピーしました。") End Function Sub 契約書() Call Fcopy("契約書用", "D1", "D3") End Sub Sub 申請() Call Fcopy("申請用", "D1", "J3") End Sub Sub 図面() Call Fcopy("図面用", "D1", "P3") End Sub

Excelでシート名の変更とシートを追加するマクロ

概要

Excelのシートを、〇月〇日～〇日というシート名に変更するマクロです。  

1つ目のシートから最後のシートまで、F1の値をシート名にしています。

もし同じ名前のシートがある場合は処理しません。

前のシートのA4のセルが日付の基準のセルとしています。

F1のセルの数式 は

『=TEXT(A4,"m月d日～")&TEXT(A4+6,"d日")』

としてセルの表示形式を整えています。 

これでA4のセルの値を基準として　〇月〇日～〇日　となります。
（このF1のセルがシート名となります。）

シート名の変更のコード

Sub シート名の変更() 'エラーを無視 On Error Resume Next '1つ目のシートから最後のシートまで繰り返す For i = 1 To Sheets.Count 'シートの名前をF1の名前にする Sheets(i).Name = Sheets(i).Range("F1").Value 'もし選択しているシートが最後ではない場合、次のシートへ移動 If ActiveSheet.Name <> Sheets(Sheets.Count).Name Then ActiveSheet.Next.Activate End If Next End Sub  

シート追加のコード  

また、シートを追加するマクロも作っています。

前のシートのA4のセルが日付の基準のセルとしています。

F1の値をシート名に変更しています。

  Sub シート追加() 'エラーを無視 On Error Resume Next '最後のシートを、その次のシートとしてコピーする Sheets(Sheets.Count).Copy After:=Sheets(Sheets.Count) '最後のシートのA4を選択 Sheets(Sheets.Count).Range("A4").Select 'A4に最後から1枚前のシートに7を足した数式を入れる（1週間なので+7） Range("A4") = "='" & Sheets(Sheets.Count - 1).Name & "'!RC+7" 'シート名をF1の名前にする Sheets(Sheets.Count).Name = Sheets(Sheets.Count).Range("F1").Value End Sub