複数のExcelのファイルを一気に開くVBA

グループウェアが浸透すれば、脱Excelして、2度手間入力など劇的に減ります。

ただ、なかなかグループウェアを導入できない環境であると、

いくつもファイルを開いて作業をすることがあります。

Pythonも便利なんですが、環境を整えたりすることが大変なこともあるので、今回はＶＢＡだけでできるものです。

A1からA3セルにファイルパスを入力しておけば、VBAマクロで開けるようになっています。

今は、Excelのみで、WordやPDFなどには対応させていません。

ファイルがないときには最後にメッセージが出るようにしています。

以下コード

Option Explicit Sub FileOpen() Dim FPath As Variant 'ファイルパスの場所 FPath = Range("A1:A3") Dim NoFile As String Dim i As Integer For i = 1 To 3 'ファイルがないときの処理 If Dir(FPath(i, 1)) = "" Then NoFile = NoFile & "『" & FPath(i, 1) & "』のファイルが存在しませんでした" & Chr(13) Else 'ファイルがあるとき　開く Workbooks.Open FPath(i, 1) End If Next MsgBox "処理がおわりました。" & Chr(13) & NoFile End Sub

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

Excelにて重複したセルを削除するマクロ

Excelにて重複したセルを削除するマクロです。

クエリなどで他のデータを読み込んで、ピポットテーブルで内容をみていますが、

メールアドレスなど項目の重複を避けたい時がありました。

クエリやピポットテーブルやには既にフィルタが適用しているし、クエリやピポットの結果による重複を避けて調べたい。ただ、もう一つクエリやピポットを作るほどでもないので、ちょっとマクロにて処理してデータを取り出しています。

マクロの内容

「データ元ファイルパス」のシートのC行をクリア
「ピポット」のシートのＧ行をコピー

「データ元ファイルパス」のシートにて
C行に値で貼り付け
C行で重複した行を削除(1行だけですが）
処理したセルをコピー（次の操作につなげるため）
C3セルを選択して、上の方を表示（次の操作がしすいため）

以下コード

Sub 重複削除() Sheets("データ元ファイルパス").Select Columns("C:C").Select Selection.Clear Sheets("ピボット").Select Columns("G:G").Select Selection.Copy Sheets("データ元ファイルパス").Select Columns("C:C").Select '値で貼り付け Selection.PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False 'C1からC200までで重複したセルを削除 ActiveSheet.Range("C1:C200").RemoveDuplicates Columns:=1, Header:=xlNo 'Columns範囲で指定した中で左から何列目か 'Header範囲内1行目をヘッダーとして扱うか（扱う場合はxlYes） Range("C3").Select '選択した位置から下に連続したセルまで選択 Range(Selection, Selection.End(xlDown)).Select '次の操作につなげるためコピー Selection.Copy '表示を上の方にするため選択 Range("C3").Select End Sub

Excelでファイルをコピーし、名前を付けて保存してからマクロ実行をワンクリックで実行

　他の人とファイルを共有していると、元のファイルに手を加えることができないことがあると思います。　しかし、いつも決まりきったデータを編集しなければならないことがあると思います。

そんな時は、みなさんどうしていますか？

元のファイルのフォルダを開いて、元のデータファイルを選んで、ファイルをコピーして、別の場所を選んで、貼り付けて、ファイルの名前を変えてから編集していますか？

　もしくは、

元のフォルダを開いて、元のデータファイルを選んで、開いて、別の名前で保存して、編集していますか？

普通にすると何手順も必要でしたが、「ファイルを開くところから、編集する」ところまでを、下記のコードのようにして、自動化しています。

Excelには、「マクロ用」というシートと、

A1のセルにはデータ元のファイルのファイルパス

例　C:\Users\●●●●\OneDrive\●●●●\●●●●.xlsx

A2のセルにはコピー先のファイルのファイルパス

例　C:\Users\●●●●\OneDrive\Desktop\□□□□.xlsx

「色付け」というマクロ

を設定しています。

　月初に1回だとしても年12回だけですが、決まりきったルーティンワークはできるだけ自動化していってます。一つ一つのコードで短縮できる時間はわずかではありますが、ちょっとずつ重ねると本当に楽になります。

　できればマクロ実行自体を自動化したい、そもそもマクロなどを実行しなくていい環境にしたいところではありますが・・・

　マクロをボタンに登録してワンクリックにて実行し、その間にトイレに行ったり、お茶したりして、次の構想を練っています。

以下コード

Option Explicit Sub A1をA2の名前でコピー() Dim ret As Long Dim FnDatamoto As String Dim FnCopysaki As String FnDatamoto = Sheets("マクロ用").Range("A1").Value FnCopysaki = Sheets("マクロ用").Range("A2").Value '同名ファイルの上書き確認 If Dir(FnCopysaki) <> "" Then ret = MsgBox("同名のファイルが存在します。" & vbCrLf & _ "上書きしますか？", vbYesNo) If ret = vbNo Then Exit Sub End If 'ファイルをデータ元からコピー先へコピーする FileCopy FnDatamoto, FnCopysaki 'コピー先のファイルを開く Workbooks.Open FnCopysaki 'ファイルを開いた先で　別のマクロを実行する　ここでは「色付け」 Call 色付け　 End Sub

Word VBAマクロ事例 次のファイルを保存してPDF出力

　Wordの差し込み文章で用意されたものを、PDF化する際に、Wordのマクロにてパパっと自動化できるようになりました。

　今までは、差し込み文章の個別編集、ファイル名変更、印刷ボタンを押し、出力先をPDFに選択して、コメントを消して、保存して、ファイル名を変更してといったことをやっていました。

　下記をWordマクロを、クイックツールバーに登録するとワンクリックでできるようになりました。 

以下コード

Sub 次ファイルを保存PDF出力() Dim fn1 As String With ActiveDocument.MailMerge .DataSource.ActiveRecord = wdNextRecord '次のレコード .Destination = wdSendToNewDocument '差し込み文章を新しくつくる .SuppressBlankLines = True '空白のデータは無視 With .DataSource fn1 = .DataFields("○○○○").Value 'ファイル名用　○○は差し込み文章のフィールドの項目 .FirstRecord = .ActiveRecord '最初のレコードはアクティブドキュメントのもの .LastRecord = .ActiveRecord '最後のレコードはアクティブドキュメントのもの End With .Execute Pause:=False '印刷エラーの時　Trueだと一時停止 End With ActiveDocument.SaveAs2 FileName:="C:\△△\□□\" & Format(Now, "yyyyMMddHHmmss") & fn1 & ".docx" ActiveDocument.SaveAs2 FileName:="●●●書（" & fn1 & "）.docx" 'ファイル名 'コメントは印刷しない ActivePrinter = "Adobe PDF" Application.PrintOut FileName:="", _ Range:=wdPrintAllDocument, _ Item:=wdPrintDocumentContent, _ PageType:=wdPrintAllPages, _ Collate:=True, Background:=True Documents("●●●書（" & fn1 & "）.docx").Close End Sub