Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


4607 / 76734 ←次へ | 前へ→

【77745】Re:特定条件の行に他シートの行を貼り付け&シート分け保存
発言  γ  - 15/12/14(月) 20:39 -

引用なし
パスワード
   一例です。

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

十分な検証をしていないので、そちらでよくチェックしてください。

4 hits

【77738】特定条件の行に他シートの行を貼り付け&シート分け保存 さいとう 15/12/12(土) 20:17 質問[未読]
【77739】Re:特定条件の行に他シートの行を貼り付け... γ 15/12/12(土) 21:07 発言[未読]
【77740】Re:特定条件の行に他シートの行を貼り付け... さいとう 15/12/12(土) 22:21 発言[未読]
【77741】Re:特定条件の行に他シートの行を貼り付け... γ 15/12/12(土) 22:40 発言[未読]
【77742】Re:特定条件の行に他シートの行を貼り付け... γ 15/12/13(日) 8:54 発言[未読]
【77743】Re:特定条件の行に他シートの行を貼り付け... さいとう 15/12/14(月) 5:24 お礼[未読]
【77745】Re:特定条件の行に他シートの行を貼り付け... γ 15/12/14(月) 20:39 発言[未読]
【77751】Re:特定条件の行に他シートの行を貼り付け... さいとう 15/12/15(火) 7:09 お礼[未読]
【77752】Re:特定条件の行に他シートの行を貼り付け... γ 15/12/15(火) 7:16 発言[未読]
【77753】Re:特定条件の行に他シートの行を貼り付け... さいとう 15/12/15(火) 18:20 お礼[未読]

4607 / 76734 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free