VBAで名前毎にファイルを作る。
いかがでしょうか
Sub SplitDataIntoFiles()
Dim ws As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim dict As Object
Dim key As Variant
Dim newFileName As String
Dim newFilePath As String
' 現在のワークシートを設定
Set ws = ThisWorkbook.Sheets("Sheet1")
' データ範囲を設定
Set rng = ws.Range("A1:C" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
' 名前ごとにデータを格納するディクショナリを作成
Set dict = CreateObject("Scripting.Dictionary")
' ディクショナリにデータを追加
For Each cell In rng.Columns(1).Cells
If cell.Row > 1 Then ' ヘッダー行をスキップ
If Not dict.exists(cell.Value) Then
dict.Add cell.Value, cell.Resize(1, 3)
Else
Set dict(cell.Value) = Union(dict(cell.Value), cell.Resize(1, 3))
End If
End If
Next cell
' 名前ごとに新しいファイルを作成
For Each key In dict.keys
' 新しいワークブックを作成
Set wsNew = Workbooks.Add(xlWBATWorksheet).Sheets(1)
' ヘッダーをコピー
ws.Rows(1).Copy Destination:=wsNew.Rows(1)
' データをコピー
dict(key).Copy Destination:=wsNew.Rows(2)
' ファイル名とパスを設定
newFileName = key & ".xlsx"
newFilePath = ThisWorkbook.Path & "\" & newFileName
' 新しいファイルを保存
wsNew.Parent.SaveAs Filename:=newFilePath
wsNew.Parent.Close SaveChanges:=False
Next key
' メッセージを表示
MsgBox "名前ごとに新しいファイルが作成されました。", vbInformation
End Sub
