【第１４回Excelマクロ】別ファイルのデータ集計と別ファイルへの出力【ほぼfor/if文】

Excel

今回は、前回に紹介した【ファイル操作】を使ってデータ処理をしていきます。

具体的な流れは以下の通りです。

  • 集計したいExcelファイルを開く
  • データの集計
  • 集計結果を別ファイルに出力

使用するデータ、集計方法については【第９回Excelマクロ】の記事と同じものとします。

前準備

まずは、テストデータのExcelファイルと、出力する表の書式をマクロファイルに作成します。

新規のマクロ有効ブック(.xlsm)を作成し、以下のコードをコピぺして実行しましょう。

※実行すると、マクロファイルと同じ階層にpikaData.xlsxファイルが作成されます。

Sub createTestData()
Dim fullName As String  '作成するファイルのパス+ファイル名
fullName = ThisWorkbook.Path & "\pikaData.xlsx"
If IsFileOpened(fullName) = True Then  '同名ファイルが開かれている確認
    MsgBox "既にファイルを開いています"
    Exit Sub    'マクロを終了
End If
If IsFileExist(fullName) = True Then  'ファイルの存在を確認
    MsgBox "既にファイルが存在しています"
    Exit Sub    'マクロを終了
End If
Workbooks.Add.SaveAs fullName '新規ブックを作成して名前を付けて保存
Workbooks.Open fullName  'ファイルのパス+ファイル名を渡してファイルを開く
Dim ws As Worksheet 'ワークシート1のオブジェクト変数を宣言
Set ws = Workbooks("pikaData.xlsx").Sheets(1)
Dim pikachuArray As Variant  'ピカチュウの配列
pikachuArray = [{"CP","HP","重さ","高さ","性別";391,64,6.5,0.4,"オス";576,81,"",0.32,"メス";350,60,6.38,0.42,"オス";534,76,7.26,0.39,"オス";424,73,9.76,0.51,"メス";311,60,7.77,0.45,"メス";119,35,5.47,0.43,"オス";501,73,7.41,0.43,"メス";489,72,4.57,0.36,"メス"}]
For i = LBound(pikachuArray, 1) To UBound(pikachuArray, 1)     'wsの1行目の1列目に2次元配列を出力
    For j = LBound(pikachuArray, 2) To UBound(pikachuArray, 2)
        ws.Cells(i, j).Value = pikachuArray(i, j)
    Next j
Next i
Workbooks("pikaData.xlsx").Close SaveChanges:=True  'ファイルを保存して閉じる
Dim ws2 As Worksheet 'ワークシート2のオブジェクト変数を宣言
Set ws2 = ThisWorkbook.Sheets(1)
Dim resultArray As Variant  '性別の各HP件数の配列
resultArray = [{"性別の各HPカテゴリ別件数","","","";"","～70","71～80","81～";"オス","","","";"メス","","",""}]
For i = LBound(resultArray, 1) To UBound(resultArray, 1)     'ws2の1行目の1列目に2次元配列を出力
    For j = LBound(resultArray, 2) To UBound(resultArray, 2)
        ws2.Cells(i, j).Value = resultArray(i, j)
    Next j
Next i
ws2.Range("A2:D4").Borders.LineStyle = xlContinuous   '格子線を引く
MsgBox "作成されました"
End Sub
Function IsFileOpened(ByVal fullName As String) As Boolean    '開いているブックに同名がないかを確認(True:開いている)
IsFileOpened = False    '初期値をFalseに設定
Dim fileName As String   'ファイル名を格納する
fileName = Dir(fullName) '「ファイルのパス+ファイル名」からファイル名を取得
Dim wb As Workbook  '開いているブックを格納するオブジェクト変数
For Each wb In Workbooks    '開いている全てのブックから同じ名前をFor文で探す
    If wb.Name = fileName Then   'ファイル名と同じブックがある場合
        IsFileOpened = True
    End If
Next wb
End Function
Function IsFileExist(ByVal fullName As String) As Boolean    'ファイルの存在確認(True:ファイルが存在する)
IsFileExist = False '初期値をFalseに設定
Dim fileName As String   'ファイル名を格納する
fileName = Dir(fullName) '「ファイルのパス+ファイル名」からファイル名を取得
If fileName <> "" Then  'ファイルが存在している
    IsFileExist = True
End If
End Function

今回実行するマクロは、別のモジュールに書いていきます。【挿入】→【標準モジュール】を選択します。Module2が挿入されたら成功です。

完成コード

先に完成したコードを見てみましょう。Module2に以下のコードをコピペします。

Sub test()
Dim fullName As String  '作成するファイルのパス+ファイル名
fullName = ThisWorkbook.Path & "\pikaData.xlsx"
If IsFileOpened(fullName) = True Then  '同名ファイルが開かれている確認
    MsgBox "既にファイルを開いています"
    Exit Sub    'マクロを終了
End If
If IsFileExist(fullName) = False Then  'ファイルの存在を確認
    MsgBox "ファイルが見つかりませんでした"
    Exit Sub    'マクロを終了
End If
Workbooks.Open fullName  'ファイルのパス+ファイル名を渡してファイルを開く
Dim ws As Worksheet 'ワークシート1のオブジェクト変数を宣言
Set ws = Workbooks("pikaData.xlsx").Sheets(1)
Dim lastRow As Long, lastCol As Long   '最終行・最終列をlong型で宣言
lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row    '最終行取得
lastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column '最終列取得
Dim seibetsuCol As Integer    '性別の列
Dim HPCol As Integer    'HPの列
For i = 1 To lastCol    'for文で性別・HPの列を検索して取得
    If ws.Cells(1, i).Value = "性別" Then
        seibetsuCol = i
    ElseIf ws.Cells(1, i).Value = "HP" Then
        HPCol = i
    End If
Next i
Dim HPArray(1 To 2, 1 To 3) As Integer  '性別の各HP件数を格納する2次元配列{例：HP(1,1)→オスのHP70以下・HP(2,2)→メスのHP71～80}
Erase HPArray   '配列を０で初期化
For i = 2 To lastRow    'for文で2行目から最終行までループ
        If ws.Cells(i, seibetsuCol).Value = "オス" Then 'オスの時の処理
            If ws.Cells(i, HPCol).Value <= 70 Then  'HPが70以下の時
                HPArray(1, 1) = HPArray(1, 1) + 1   'HPArray(1, 1)をカウントアップ
            ElseIf ws.Cells(i, HPCol).Value >= 71 And ws.Cells(i, HPCol).Value <= 80 Then   'HP71～80の時
                HPArray(1, 2) = HPArray(1, 2) + 1   'HPArray(1, 2)をカウントアップ
            Else    'それ以外の時（HP81以上）
                HPArray(1, 3) = HPArray(1, 3) + 1   'HPArray(1, 3)をカウントアップ
            End If
        ElseIf ws.Cells(i, seibetsuCol).Value = "メス" Then 'メスの時も同様に処理
            If ws.Cells(i, HPCol).Value <= 70 Then
                HPArray(2, 1) = HPArray(2, 1) + 1
            ElseIf ws.Cells(i, HPCol).Value >= 71 And ws.Cells(i, HPCol).Value <= 80 Then
                HPArray(2, 2) = HPArray(2, 2) + 1
            Else
                HPArray(2, 3) = HPArray(2, 3) + 1
            End If
        End If
Next i
Workbooks("pikaData.xlsx").Close SaveChanges:=False  'ファイルを保存せず閉じる
Dim outputFullName As String  '出力先の作成するファイルのパス+ファイル名
outputFullName = ThisWorkbook.Path & "\outputPikaData.xlsx"
If IsFileOpened(outputFullName) = True Then  '同名ファイルが開かれている確認
    MsgBox "既にファイルを開いています"
    Exit Sub    'マクロを終了
End If
If IsFileExist(outputFullName) = True Then  'ファイルの存在を確認
    Dim ans As Integer
    ans = MsgBox("ファイルが既に存在します。上書きしますか？", vbYesNo)
    If ans = vbYes Then
        Kill outputFullName '既存のoutputFullNameを削除
    Else
        MsgBox "キャンセルされました"
        Exit Sub    'マクロを終了
    End If
End If
Workbooks.Add.SaveAs outputFullName '新規ブックを作成して名前を付けて保存
Workbooks.Open outputFullName  'ファイルのパス+ファイル名を渡してファイルを開く
ThisWorkbook.Worksheets(1).Copy Before:=Workbooks("outputPikaData.xlsx").Sheets(1)   'マクロファイルのシート1をコピーしてoutputPikaData.xlsxのシート1の前の位置に挿入
Workbooks("outputPikaData.xlsx").Sheets(1).Name = "PIKA" 'シート名をPIKAに変更する
Application.DisplayAlerts = False   '削除メッセージの非表示
Workbooks("outputPikaData.xlsx").Sheets(2).Delete   '不要なシートを削除
Application.DisplayAlerts = True    'メッセージを表示に戻す
Dim ws2 As Worksheet '出力するファイルのワークシート1のオブジェクト変数を宣言
Set ws2 = Workbooks("outputPikaData.xlsx").Sheets(1)
For i = LBound(HPArray, 1) To UBound(HPArray, 1)    'シート２に配列HPArrayを出力
    For j = LBound(HPArray, 2) To UBound(HPArray, 2)
        ws2.Cells(i + 2, j + 1).Value = HPArray(i, j)
    Next j
Next i
Workbooks("outputPikaData.xlsx").Close SaveChanges:=True  'ファイルを保存して閉じる
MsgBox "作成されました"
End Sub
Function IsFileOpened(ByVal fullName As String) As Boolean    '開いているブックに同名がないかを確認(True:開いている)
IsFileOpened = False    '初期値をFalseに設定
Dim fileName As String   'ファイル名を格納する
fileName = Dir(fullName) '「ファイルのパス+ファイル名」からファイル名を取得
Dim wb As Workbook  '開いているブックを格納するオブジェクト変数
For Each wb In Workbooks    '開いている全てのブックから同じ名前をFor文で探す
    If wb.Name = fileName Then   'ファイル名と同じブックがある場合
        IsFileOpened = True
    End If
Next wb
End Function
Function IsFileExist(ByVal fullName As String) As Boolean    'ファイルの存在確認(True:ファイルが存在する)
IsFileExist = False '初期値をFalseに設定
Dim fileName As String   'ファイル名を格納する
fileName = Dir(fullName) '「ファイルのパス+ファイル名」からファイル名を取得
If fileName <> "" Then  'ファイルが存在している
    IsFileExist = True
End If
End Function</code></pre>

コードの解説

ファイルを開く

【第１３回Excelマクロ】で作成した関数 IsFileOpened・IsFileExistを使い、同名ファイルが開いているか・ファイルが存在しているかをチェックし、問題がなければファイルを開いています。

If IsFileOpened(fullName) = True Then  '同名ファイルが開かれている確認
    MsgBox "既にファイルを開いています"
    Exit Sub    'マクロを終了
End If
If IsFileExist(fullName) = False Then  'ファイルの存在を確認
    MsgBox "ファイルが見つかりませんでした"
    Exit Sub    'マクロを終了
End If
Workbooks.Open fullName  'ファイルのパス+ファイル名を渡してファイルを開く

データの集計

集計方法については【第９回Excelマクロ】のコードをコピペしているので解説は割愛します。

集計の前に、集計するファイルのシート(1)のオブジェクトをオブジェクト変数 wsに格納しています。

Dim ws As Worksheet '集計するファイルのワークシート1のオブジェクト変数を宣言
Set ws = Workbooks("pikaData.xlsx").Sheets(1)

集計後、ファイルを保存せずに閉じます。

Workbooks("pikaData.xlsx").Close SaveChanges:=False  'ファイルを保存せず閉じる

集計結果の出力

集計結果は配列に格納しているので、あとは

・出力したい新しいブックの作成

・マクロファイルにある表の書式をシートごとコピー

・新規作成したブックに貼り付け

・配列を書き出す

となっています。

まずは、出力するファイルのパス+ファイル名をオブジェクト変数に格納します。その後、同名のファイルが開かれているかの確認しています。

Dim outputFullName As String  '出力先の作成するファイルのパス+ファイル名
outputFullName = ThisWorkbook.Path & "\outputPikaData.xlsx"
If IsFileOpened(outputFullName) = True Then  '同名ファイルが開かれている確認
    MsgBox "既にファイルを開いています"
    Exit Sub    'マクロを終了
End If

次に、MsgBox関数という関数を初めて使います。これは、【上書きしますか？】とメッセージを表示し「はい」「いいえ」でユーザーが選択できるボタンを表示します。押されたボタンで処理が分岐し、Yesが押されたら「Kill outputFullName」で既存のファイルを削除します。MsgBox関数に関しては以下のリンク参照。

MsgBox関数について

If IsFileExist(outputFullName) = True Then  'ファイルの存在を確認
    Dim ans As Integer
    ans = MsgBox("ファイルが既に存在します。上書きしますか？", vbYesNo)
    If ans = vbYes Then
        Kill outputFullName '既存のoutputFullNameを削除
    Else
        MsgBox "キャンセルされました"
        Exit Sub    'マクロを終了
    End If
End If
Workbooks.Add.SaveAs outputFullName '新規ブックを作成して名前を付けて保存
Workbooks.Open outputFullName  'ファイルのパス+ファイル名を渡してファイルを開く

新規ブックを作成してファイルを開きます。

Workbooks.Add.SaveAs outputFullName '新規ブックを作成して名前を付けて保存
Workbooks.Open outputFullName  'ファイルのパス+ファイル名を渡してファイルを開く

次に、マクロファイルのシート(1)をコピーし、出力するファイルに貼り付けます。

ThisWorkbook.Worksheets(1).Copy Before:=Workbooks("outputPikaData.xlsx").Sheets(1)   'マクロファイルのシート1をコピーしてoutputPikaData.xlsxのシート1の前の位置に挿入
Workbooks("outputPikaData.xlsx").Sheets(1).Name = "PIKA" 'シート名をhogeに変更する

出力するファイルのシートが２つになったので、不要なシート１を削除します。削除前に、削除メッセージがでないように「Application.DisplayAlerts = False」で設定し、削除後にその設定を戻しています。

Application.DisplayAlerts = False   '削除メッセージの非表示
Workbooks("outputPikaData.xlsx").Sheets(2).Delete   '不要なシートを削除
Application.DisplayAlerts = True    'メッセージを表示に戻す

出力するファイルに、集計したデータを出力します。出力後、ファイルを保存して閉じています。

Dim ws2 As Worksheet '出力するファイルのワークシート1のオブジェクト変数を宣言
Set ws2 = Workbooks("outputPikaData.xlsx").Sheets(1)
For i = LBound(HPArray, 1) To UBound(HPArray, 1)    'シート２に配列HPArrayを出力
    For j = LBound(HPArray, 2) To UBound(HPArray, 2)
        ws2.Cells(i + 2, j + 1).Value = HPArray(i, j)
    Next j
Next i
Workbooks("outputPikaData.xlsx").Close SaveChanges:=True  'ファイルを保存して閉じる

デスクトップに「outputPikaData.xlsx」というファイルが作成されているので、開いてみましょう。下図のようになっていれば成功です。

最後に

前回までの記事のコードをコピペし、データ集計のマクロを作ってみました。

今回は、表の書式をマクロファイルのシートに作成しましたが、別ファイルに用意しておいて運用してもよいですね。

いろいろ応用して、ぜひ使ってみてください。

【Excelマクロ】記事のまとめ【ほぼfor/if文】
これまでの記事のまとめです。VBAエキスパート Excelベーシック受験【2025年１月】VBAエキスパート Excel VBA ベーシック【Excelマクロ】導入【第１回Excelマクロ】導入について【ほぼfor/if文】セルの値の取得・...
poppoco-works.blog
2025.07.18
スポンサーリンク

コメント

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