EXCEL マクロ

質問

コード 住所　電話番号・・・・
1_東京_03
1_大阪_06
1_静岡_054
2_愛知_052
2_岐阜_058
2_三重_059

シート名:コード1
コード 住所　電話番号
1_東京_03
1_大阪_06
1_静岡_054
コード 住所　電話番号
シート名：コード２
2_愛知_052
2_岐阜_058
2_三重_059

コードごとに行全体を新規シートに貼り付けはマクロで出来るでしょうか？
手作業では膨大な時間が掛かるため、出来ればと思います。

回答No.2

end-u · ベストアンサー

行全体のコピーが必須なら以下は読み飛ばしてください。

データ部分の値だけを新規シートに貼り付けるのでも構わないなら、
見出しがある事、またA1セルから連続領域がデータ部分となっている事、
が前提ですが、

A)[フィルタオプションの設定]AdvancedFilterメソッドを使う方法

まず、キーとなるデータのユニーク値をAdvancedFilterを使って取り出し、
そのユニーク値をLoopし、それぞれ検索条件に指定して新規シートに抽出します。
作業列としてIU:IV列を使います。

Sub try_1()
　　Dim r　As Range
　　Dim ri As Range

　　With ActiveSheet
　　　　.Columns(1).AdvancedFilter Action:=xlFilterCopy, _
　　　　　　　　　　　　　　　　　 CopyToRange:=.Range("IU1"), _
　　　　　　　　　　　　　　　　　 Unique:=True
　　　　.Range("IV1").Value = .Range("IU1").Value
　　　　Set r = .Range("A1").CurrentRegion
　　　　For Each ri In .Range("IU2", .Cells(.Rows.Count, "IU").End(xlUp))
　　　　　　.Range("IV2").Value = ri.Value
　　　　　　r.AdvancedFilter Action:=xlFilterCopy, _
　　　　　　　　　　　　　　 CriteriaRange:=.Range("IV1:IV2"), _
　　　　　　　　　　　　　　 CopyToRange:=Sheets.Add.Cells(1), _
　　　　　　　　　　　　　　 Unique:=True
　　　　Next
　　　　.Columns("IU:IV").Delete
　　End With

　　Set r = Nothing
End Sub

B)[ピボットテーブル]ShowDetailプロパティを使う方法

PivotTableでキーとなるデータを基準にダミー集計し、
それぞれの集計行で[詳細データの表示]をすると新規シートにデータが抽出されます。
作業列としてIU:IV列を使います。

Sub try_2()
　　Dim r As Range

　　With ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _
　　　　　　　　　　　　　　　　　　　　SourceData:=Range("A1").CurrentRegion.Address(external:=True)) _
　　　　　　　　　　　　　　　　　　　　.CreatePivotTable(TableDestination:=Range("IU1"))
　　　　.PivotFields(1).Orientation = xlRowField
　　　　.PivotFields(1).Orientation = xlDataField
　　　　.ColumnGrand = False
　　　　For Each r In .DataBodyRange
　　　　　　r.ShowDetail = True
　　　　Next
　　　　.TableRange2.Clear
　　End With
End Sub

２つのコードとも標準モジュールに置いて、データがあるシートをActiveにして実行します。

お礼

ありがとうございます。
書いてあることの半分程度しか理解できませんが、作成できました。
ありがとうございました。

回答No.1

hige_082

出力先のシートは作成しておいて下さい
元データのシート名が無いので「sheet1」としています
コードの数値を文字列「コード」の後に付加して
それを出力シート名としてコピペするだけのマクロ

Sub test()
Dim i As Long
With Worksheets("sheet1")
For i = 2 To .Range("a65536").End(xlUp).Row
.Cells(i, 1).Resize(1, 3).Copy _
Worksheets("コード" & .Cells(i, 1).Value).Range("a65536").End(xlUp).Offset(1)
Next i
End With
End Sub

参考まで

お礼

回答ありがとうございます。
実行しますと、なぜか3列分しかコピーされないようです。
エラー"9"がでます。
すべてのシートを作成していないからだと思いますが・・・
改善できるマクロの知識がないので手作業でやりたいと思います。
ありがとうございました。