【永久保存版!!!】私の作ったマクロの大半がこれ！選択したファイルからデータを取得して集計データ的なものを作る

出戻りガツオ🐟

2021年2月8日 22:10

こんばんは。カツオです。
前回堂々と「次回手抜きします！！」って言っていたのに、
気が変わってガチでマクロ書きました！前回のはこちら↓

いや、前回パスワードを一括で設定するやつ書いたから今回は一括で解除するっていう手抜きネタをやろうとしたんですけど、なんか謎のやる気が出たので、自分のノウハウの棚卸のためにも特によく使う系のマクロを書きました！

人事労務、経理系の仕事は謎の集計データ作成業務が多い

こう思っているの私だけですかね。これ（人事労務）関連の仕事するの3社目ですけどもうバカの一つ覚えみたいにそれぞれのニーズに合わせた集計データ作ってますよ！！！！

ホントにいるのか！？って思うくらい部門のニーズに合わせて集計データ作ってます。

そういうのって大体VLOOKUP関数だのSUMIF関数がガッツリ書き込まれたコピー元ファイルを都度複製してデータソースを入力するってイメージですが皆さんのところはどうでしょう？

大体、こんな。もう相場が決まってるっつーのって思いますわよ。
こんな作業こそマクロにしましょ。そうしましょう！

選択したファイルからデータを取得して集計データ的なものを作る

Option Explicit
Private Enum ColumnNumber
Source_Header_Row = 1
Source_Title_Column1 = 1
Source_Title_Column2 = 2
Source_Title_Column3 = 3
Source_Title_Column4 = 4
Source_Title_Column5 = 5
Source_Title_Column6 = 6
Source_Title_Column7 = 7
Source_Title_Column8 = 8
Source_Title_Column9 = 9
Create_Header_Row = 1
Create_Title_Column1 = 1
Create_Title_Column2 = 2
Create_Title_Column3 = 3
Create_Title_Column4 = 4
Create_Title_Column5 = 5
Create_Title_Column6 = 6
Create_Title_Column7 = 7
Create_Title_Column8 = 8
Create_Title_Column9 = 9
End Enum
Sub CreateExcelData()
   'ファイルの選択
   Dim SourceFilePath As String
   '複数選択可能のダイアログボックスを開く
   SourceFilePath = Application.GetOpenFilename("Microsoft Excelブック,*.xlsx,CSV ファイル,*.csv")
   If SourceFilePath = "" Then Exit Sub
   
   Dim CreateFileSource As String: CreateFileSource = ThisWorkbook.Path & "\01_書式\集計.xlsx" '作成する集計データのコピー用ファイル保管場所
   Dim CreateFileName As String: CreateFileName = "集計表_" & Format(Now, "YYYYMMDDHHMMSS") & ".xlsx"  '作成するファイル名はここで指定する
   Dim CreateFilePath As String: CreateFilePath = ThisWorkbook.Path & "\02_出力\" & CreateFileName '作成する集計データの出力先
   Const PstTargetSht As String = "データソース" 'データの貼り付け先の名前はここで設定・・・エラーチェックの対象は省いています・・・
   
    '①エラー対処
   If ErrCheck(SourceFilePath, CreateFileSource, CreateFilePath) = False Then Exit Sub
   '実行
   'Start
   With Application
       .ScreenUpdating = False
       .EnableEvents = False
       .Calculation = xlCalculationManual
   End With
   Dim SourceBook As Workbook, CreateBook As Workbook
   Dim LastRow As Long
   Dim PstArray As Variant '転写用の値格納配列
   '1.データソースを開く
   Workbooks.Open Filename:=SourceFilePath
   Set SourceBook = Workbooks(Dir(SourceFilePath))
   '一列目の最終行がデータソースの最終行と設定する　フィルタかかっている場合などの対処はCurrentRegionが望ましい
   'データソースはシート一枚と仮定してマクロは作っています。シート名を指定したいのであればActiveSheetを修正してください
   LastRow = SourceBook.ActiveSheet.Cells(Rows.Count, ColumnNumber.Source_Title_Column1).End(xlUp).Row
   '2.複製用の集計データを開く
   Workbooks.Open Filename:=CreateFileSource
   Set CreateBook = Workbooks(Dir(CreateFileSource))
   
   '<★ここが肝★>3.試しにデータソースの列から列へデータを転写する仕組みにしています。転写先はここで指定してください
   '変数名のセンスの無さなどからやたらめったらに長いコードなってますが、変数名工夫すればもっとぐっと見やすくなります。
   '一列目
   With SourceBook.ActiveSheet
       PstArray = .Range(.Cells(Source_Header_Row + 1, ColumnNumber.Source_Title_Column1), .Cells(LastRow, ColumnNumber.Source_Title_Column1))
   End With
   With CreateBook.Sheets(PstTargetSht)
       .Range(.Cells(ColumnNumber.Create_Header_Row + 1, ColumnNumber.Create_Title_Column1), _
                                                   .Cells(LastRow - Source_Header_Row + ColumnNumber.Create_Header_Row, ColumnNumber.Create_Title_Column1)) = PstArray
   End With
   '二列目
   With SourceBook.ActiveSheet
       PstArray = .Range(.Cells(Source_Header_Row + 1, ColumnNumber.Source_Title_Column2), .Cells(LastRow, ColumnNumber.Source_Title_Column2))
   End With
   With CreateBook.Sheets(PstTargetSht)
       .Range(.Cells(ColumnNumber.Create_Header_Row + 1, ColumnNumber.Create_Title_Column2), _
                                                   .Cells(LastRow - Source_Header_Row + ColumnNumber.Create_Header_Row, ColumnNumber.Create_Title_Column2)) = PstArray
   End With
   '三列目
   With SourceBook.ActiveSheet
       PstArray = .Range(.Cells(Source_Header_Row + 1, ColumnNumber.Source_Title_Column3), .Cells(LastRow, ColumnNumber.Source_Title_Column3))
   End With
   With CreateBook.Sheets(PstTargetSht)
       .Range(.Cells(ColumnNumber.Create_Header_Row + 1, ColumnNumber.Create_Title_Column3), _
                                                   .Cells(LastRow - Source_Header_Row + ColumnNumber.Create_Header_Row, ColumnNumber.Create_Title_Column3)) = PstArray
   End With
   '四列目
   With SourceBook.ActiveSheet
       PstArray = .Range(.Cells(Source_Header_Row + 1, ColumnNumber.Source_Title_Column4), .Cells(LastRow, ColumnNumber.Source_Title_Column4))
   End With
   With CreateBook.Sheets(PstTargetSht)
       .Range(.Cells(ColumnNumber.Create_Header_Row + 1, ColumnNumber.Create_Title_Column4), _
                                                   .Cells(LastRow - Source_Header_Row + ColumnNumber.Create_Header_Row, ColumnNumber.Create_Title_Column4)) = PstArray
   End With
   '五列目
   With SourceBook.ActiveSheet
       PstArray = .Range(.Cells(Source_Header_Row + 1, ColumnNumber.Source_Title_Column5), .Cells(LastRow, ColumnNumber.Source_Title_Column5))
   End With
   With CreateBook.Sheets(PstTargetSht)
       .Range(.Cells(ColumnNumber.Create_Header_Row + 1, ColumnNumber.Create_Title_Column5), _
                                                   .Cells(LastRow - Source_Header_Row + ColumnNumber.Create_Header_Row, ColumnNumber.Create_Title_Column5)) = PstArray
   End With
   '六列目
   With SourceBook.ActiveSheet
       PstArray = .Range(.Cells(Source_Header_Row + 1, ColumnNumber.Source_Title_Column6), .Cells(LastRow, ColumnNumber.Source_Title_Column6))
   End With
   With CreateBook.Sheets(PstTargetSht)
       .Range(.Cells(ColumnNumber.Create_Header_Row + 1, ColumnNumber.Create_Title_Column6), _
                                                   .Cells(LastRow - Source_Header_Row + ColumnNumber.Create_Header_Row, ColumnNumber.Create_Title_Column6)) = PstArray
   End With
   '七列目
   With SourceBook.ActiveSheet
       PstArray = .Range(.Cells(Source_Header_Row + 1, ColumnNumber.Source_Title_Column7), .Cells(LastRow, ColumnNumber.Source_Title_Column7))
   End With
   With CreateBook.Sheets(PstTargetSht)
       .Range(.Cells(ColumnNumber.Create_Header_Row + 1, ColumnNumber.Create_Title_Column7), _
                                                   .Cells(LastRow - Source_Header_Row + ColumnNumber.Create_Header_Row, ColumnNumber.Create_Title_Column7)) = PstArray
   End With
   '八列目
   With SourceBook.ActiveSheet
       PstArray = .Range(.Cells(Source_Header_Row + 1, ColumnNumber.Source_Title_Column8), .Cells(LastRow, ColumnNumber.Source_Title_Column8))
   End With
   With CreateBook.Sheets(PstTargetSht)
       .Range(.Cells(ColumnNumber.Create_Header_Row + 1, ColumnNumber.Create_Title_Column8), _
                                                   .Cells(LastRow - Source_Header_Row + ColumnNumber.Create_Header_Row, ColumnNumber.Create_Title_Column8)) = PstArray
   End With
   '九列目
   With SourceBook.ActiveSheet
       PstArray = .Range(.Cells(Source_Header_Row + 1, ColumnNumber.Source_Title_Column9), .Cells(LastRow, ColumnNumber.Source_Title_Column9))
   End With
   With CreateBook.Sheets(PstTargetSht)
       .Range(.Cells(ColumnNumber.Create_Header_Row + 1, ColumnNumber.Create_Title_Column9), _
                                                   .Cells(LastRow - Source_Header_Row + ColumnNumber.Create_Header_Row, ColumnNumber.Create_Title_Column9)) = PstArray
   End With
   '終わったらファイルを保存する
   Application.DisplayAlerts = False
   SourceBook.Close
   With Application
       .Calculation = xlCalculationAutomatic
       .DisplayAlerts = True
   End With
   CreateBook.SaveAs CreateFilePath
   '～End
   Set SourceBook = Nothing
   Set CreateBook = Nothing
   With Application
       .ScreenUpdating = True
       .EnableEvents = True
   End With
   MsgBox "作業が完了いたしました。", vbInformation, "メッセージ"
End Sub
Function ErrCheck(ByVal SourceFilePath As String, ByVal CreateFileSource As String, ByVal CreateFilePath As String) As Boolean
   ErrCheck = True
   '①複製用の集計ファイルの元データが見つからない場合にエラーを返す
   If Dir(CreateFileSource) = "" Then
       MsgBox "フォーマットが見つかりません", vbCritical, "Error"
       ErrCheck = False
       Exit Function
   End If
   '②作成する同名のファイルが存在しないか確認する、ある場合にエラーを返す
   If Dir(CreateFilePath) <> "" Then
       MsgBox "同名のファイルが存在します", vbCritical, "Error"
       ErrCheck = False
       Exit Function
   End If
   '③元データかコピー用のファイルと同名のファイルを開いていないか確認する、ある場合にエラーを返す
   Dim wb As Workbook
   For Each wb In Workbooks
       If wb.Name = Dir(SourceFilePath) Or wb.Name = Dir(CreateFileSource) Or wb.Name = Dir(CreateFilePath) Then
           MsgBox "作業用のファイルは閉じてください", vbCritical, "Error"
           ErrCheck = False
           Exit Function
       End If
   Next wb
End Function

ちょっと長いっすね・・・。Moduleまるまる埋めるくらいのボリュームです。
特徴として列挙型変数を使っています。詳しくはこちら！

Source~の変数がデータソースのヘッダー番号やら列番号の指定、
Create~の変数が貼り付け先のヘッダー番号や列番号の指定です。

最近になって列番号や行番号とか文字列とか何らかの都合で変わる代物は最初の方に変数とか定数で指定した方がいいな！って思いました！

Private Enum ColumnNumber
Source_Header_Row = 1
Source_Title_Column1 = 1
Source_Title_Column2 = 2
Source_Title_Column3 = 3
Source_Title_Column4 = 4
Source_Title_Column5 = 5
Source_Title_Column6 = 6
Source_Title_Column7 = 7
Source_Title_Column8 = 8
Source_Title_Column9 = 9
Create_Header_Row = 1
Create_Title_Column1 = 1
Create_Title_Column2 = 2
Create_Title_Column3 = 3
Create_Title_Column4 = 4
Create_Title_Column5 = 5
Create_Title_Column6 = 6
Create_Title_Column7 = 7
Create_Title_Column8 = 8
Create_Title_Column9 = 9
End Enum

ここで列番号やら行番号を指定してくださいね。

開けるファイルは拡張子が「.xlsx」か「.csv」

今回データソースとして指定できる拡張子は「.xlsx」か「.csv」に限定しました。MultiSelectも無し。データソースは一枚もののシートを想定しています。

やたらめったらに長くなるコードはA1セルから下と右に連続でズラーっと並べるコードだったら

変数（Variant型） = Range(A1).CurrentRegion

みたいなやつで配列で取得した方が綺麗にかけます。ってか基本私はそう書きます。

エラー対策はこんな感じ！

Function ErrCheck(ByVal SourceFilePath As String, ByVal CreateFileSource As String, ByVal CreateFilePath As String) As Boolean
   ErrCheck = True
   '①複製用の集計ファイルの元データが見つからない場合にエラーを返す
   If Dir(CreateFileSource) = "" Then
       MsgBox "フォーマットが見つかりません", vbCritical, "Error"
       ErrCheck = False
       Exit Function
   End If
   '②作成する同名のファイルが存在しないか確認する、ある場合にエラーを返す
   If Dir(CreateFilePath) <> "" Then
       MsgBox "同名のファイルが存在します", vbCritical, "Error"
       ErrCheck = False
       Exit Function
   End If
   '③元データかコピー用のファイルと同名のファイルを開いていないか確認する、ある場合にエラーを返す
   Dim wb As Workbook
   For Each wb In Workbooks
       If wb.Name = Dir(SourceFilePath) Or wb.Name = Dir(CreateFileSource) Or wb.Name = Dir(CreateFilePath) Then
           MsgBox "作業用のファイルは閉じてください", vbCritical, "Error"
           ErrCheck = False
           Exit Function
       End If
   Next wb
End Function

今回設定したエラー対策は下記の対策をしています。

①コピー用の集計シートが見つからない
②同じファイル名のものを作ろうとしない
③作業用のファイルと同じファイル名のファイルを開かない

諦めているのはシート名のチェックですね。本当に指定したシートが存在するのか、そのチェックは端折ってます。

書き方が多様なマクロです

私が書いたマクロはあくまで一例です。オブジェクト変数だったり、そもそもデータを配列でとったりとやり方は異なっています。伝えたいのは

事務系の仕事、結構この順序で終わるもの多くないですか？

っていうことです。

作ってみる内容としてはとっつきやすいマクロ

特に人事労務・経理関係の仕事の人にはおすすめです！！！

トライしてみてくださいね！！！！

この記事が参加している募集

#最近の学び

181,465件

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