| |
一例です。
Sub test()
Dim ws As Worksheet
Dim newBook As Workbook
Dim lastRow As Long
Dim myRng As Range
Dim myRng2 As Range
Dim wsNew As Worksheet
Dim r As Range
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set newBook = Workbooks.Add
'"項目"のみ抽出
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Set myRng = ws.Range("A1", ws.Cells(lastRow, 4))
myRng.AutoFilter Field:=1, Criteria1:="項目"
' その一列目の可視セルを変数に持つ
Set myRng2 = ws.Range("A2", ws.Cells(lastRow, 1)).SpecialCells(xlCellTypeVisible)
'オートフィルターを解除
myRng.AutoFilter
'各ブロックについて処理
For Each r In myRng2
'見出しのコピー
ThisWorkbook.Sheets("見出し").Rows(2).Copy r
'各ブロックを別々のシートに転記
Set wsNew = newBook.Worksheets.Add(after:=newBook.Worksheets(newBook.Worksheets.Count))
r.CurrentRegion.Copy wsNew.Range("A1")
wsNew.Name = r(1).Offset(-1).Value
Next
End Sub
十分な検証をしていないので、そちらでよくチェックしてください。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
