Excel VBAでデータを分割し、ピボットテーブルを更新する方法

Excel VBAを使ってデータを複数のファイルに分割し、ピボットテーブルも一緒にコピーして更新する方法について解説します。質問者様が直面している問題について、分割したファイルに余計なデータが入ってしまう現象を解決するためのコードの修正ポイントやアドバイスを提供します。

1. 元ファイルのデータを基にして分割する方法
2. ピボットテーブルを新しいシートに更新する方法
3. ファイル名に月日を付ける方法
4. コードの修正例
5. まとめ

1. 元ファイルのデータを基にして分割する方法

まず、元ファイルの1つ目のシートを基にして、データを分割する手順について説明します。コードはA列を基準にしてデータをグループ化し、それぞれのグループに対して新しいワークブックを作成し、データをコピーします。ここで注意すべき点は、ピボットテーブルが含まれる2〜5シートも一緒にコピーする点です。

次に、データをコピーする際、元のシートから新しいワークシートにヘッダーやデータのコピーを行い、フィルタリングを使用して必要なデータのみを選択します。その後、新しいワークブックを指定したパスに保存します。

2. ピボットテーブルを新しいシートに更新する方法

質問者様が問題として挙げたピボットテーブルの更新については、分割された新しいファイルに移行した後もピボットテーブルが正しく更新されるようにする必要があります。ピボットテーブルを新しいシートにコピーした場合、コピー元のデータが変わることで、ピボットテーブルのリンクやフィールドが無効になってしまうことがあります。

これを解決するためには、VBAでピボットテーブルのキャッシュを更新する必要があります。コードを追加して、新しいデータがピボットテーブルに反映されるようにしましょう。

3. ファイル名に月日を付ける方法

分割後のファイル名に特定のフォーマット（例:【2025年●月】データ（20250701～202050731））を自動的に付ける方法について説明します。月日を自動的に入力するためには、VBA内で日付の関数を使用し、ファイル名を動的に作成します。

これには、VBAで「DateAdd」関数を使用して、現在の日付から1ヶ月前の月日を取得し、それをファイル名に組み込みます。これにより、毎月更新されるファイル名を自動で生成できます。

4. コードの修正例

質問者様のコードでは、分割後に2行目がすべてコピーされてしまうという問題が発生しているとのことです。この問題を解決するためには、データをコピーする範囲を正確に指定する必要があります。特に、ヘッダー行を除外してデータだけをコピーするように範囲を調整します。

以下は、修正されたVBAコードの例です。

Sub SplitDataIntoFiles()
 Dim ws As Worksheet
 Dim rng As Range
 Dim cell As Range
 Dim dict As Object
 Dim key As Variant
 Dim newWB As Workbook
 Dim newWS As Worksheet
 Dim lastRow As Long
 Dim lastCol As Long
 Dim savePath As String
 ' 保存先フォルダを指定
 savePath = "C:\Your\Save\Path\" 
 ' 現在のシートを取得
 Set ws = ThisWorkbook.Sheets(1)
 lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
 lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
 ' データ範囲を取得
 Set rng = ws.Range(ws.Cells(2, 1), ws.Cells(lastRow, lastCol))
 ' Dictionaryオブジェクトを作成
 Set dict = CreateObject("Scripting.Dictionary")
 ' 指定列（例: 1列目）を基準にグループ化
 For Each cell In rng.Columns(1).Cells
 If Not dict.exists(cell.Value) Then
 dict.Add cell.Value, cell.Value
 End If
 Next cell
 ' グループごとに新しいファイルを作成
 For Each key In dict.keys
 ' 新しいブックを作成
 Set newWB = Workbooks.Add
 Set newWS = newWB.Sheets(1)
 ' ヘッダーをコピー
 ws.Rows(1).Copy Destination:=newWS.Rows(1)
 ' 該当データをコピー
 rng.AutoFilter Field:=1, Criteria1:=key
 ws.Rows("2:" & lastRow).SpecialCells(xlCellTypeVisible).Copy Destination:=newWS.Rows(2)
 ' フィルター解除
 ws.AutoFilterMode = False
 ' ファイルを保存
 newWB.SaveAs savePath & key & ".xlsx"
 newWB.Close SaveChanges:=False
 Next key
 MsgBox "ファイル分割が完了しました！", vbInformation
 End Sub