可変ブロックごとにコピー

はじめまして。よろしくお願いします。

使用環境はEXCEL2013です。

添付画像のような【元シート】(シート名：元シート)のデータを
【転記シート】(シート名：転記シート；事前に用意)に転記したい
と考えてます。良い方法をご教示いただけないでしょうか？
よろしくお願いします。

・元データは7000行くらい
・元データＡ列のキーが変わるごとに対応するブロック毎を別シートに転記。
・Ａ列の同一キーの行数は可変(1～50行)
・転記は４つのキー(４ブロック)ごとに下側に転記場所を変える
・Ｅ，Ｊ，Ｏ列は空列
・画像例では５行目は空行（上段のデータ数によって空行を入れる位置がかわります）

ややこしくて申し訳ありませんが、不明な点がありましたら補足いたしますので、
よろしくお願いします。

No.1 ベストアンサー 回答者： tom04 回答日時： 2017/08/25 17:03

こんにちは！

VBAになりますが一例です。
「元シート」には項目行がなくて、1行目からデータがあり、
列方向に関してはA～E列までのデータだとします。

尚、Sheet3を作業用のシートとして使用していますので、Sheet3は使っていない状態にしておいてください。
標準モジュールです。

Sub Sample1()
Dim i As Long, cnt As Long, lastRow As Long
Dim myRow As Long, wS2 As Worksheet, wS3 As Worksheet
Set wS2 = Worksheets("転記シート")
Set wS3 = Worksheets("Sheet3")
Application.ScreenUpdating = False
wS2.Cells.Clear
With Worksheets("元シート")
.Rows(1).Insert
.Range("A1") = "ダミー"
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True
myRow = 1
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
.Range("A1").AutoFilter field:=1, Criteria1:=wS3.Cells(i, "A")
cnt = cnt + 1
If cnt > 4 Then
cnt = 1
myRow = wS2.UsedRange.Rows.Count + 2
End If
Range(.Cells(2, "B"), .Cells(lastRow, "E")).SpecialCells(xlCellTypeVisible).Copy _
wS2.Cells(myRow, (cnt - 1) * 5 + 1)
Next i
.Rows(1).Delete
wS3.Cells.Clear
wS2.Columns.AutoFit
wS2.Activate
End With
Application.ScreenUpdating = True
MsgBox "完了"
End Sub

こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

こんにちは。
早速のお返事、誠にありがとうございます。

完璧です！感動しました。

何時間もかけてやっていた手作業が一瞬で終わりました。
まだ、ＶＢＡのコードの意味は理解できていないのですが、
いろいろなことに応用できそうなので、勉強しつつ解読してみたいと
思います。

本当にありがとうございました。

お礼日時：2017/08/25 17:56