膨大なデータ一行おきに二行分のコピーしたセルを挿入

質問

エクセルが苦手で困っています。
エクセル、マクロに詳しい方教えて下さい。
10000件ある住所の一覧データに１行おきにコピーした２行分のセルを挿入したいのですが、
10000件を1件づつコピーしたセルの挿入を繰り返すのは気が遠くなりそうです。
一気にコピーした２行分のセルを１件おきに挿入する良い方法はありませんでしょうか？
マクロやエクセルでの方法を教えて下さい！

【例】
番号 郵便番号 住所 名前
1 123-4567 ○○県○○市○○町 春本　春子
2 111-1111 △△県△△市△町 　　　　　　夏野　夏美
3 222-2222 □□県□□市□□町 秋田　秋夫
4 333-3333 ××県××市××町 冬川　冬彦
〃　　　　　　　〃　　　　　　　　　　　　　　　〃　　　　　　　　　　　　　　〃
〃　　　　　　　〃　　　　　　　　　　　　　　　〃　　　　　　　　　　　　　　〃
10000 　　〃　　　　　　　　　　　　　　　〃　　　　　　　　　　　　　　〃

↓

番号 郵便番号 住所 名前
1 123-4567 ○○県○○市○○町 春本　春子
2013 5000 250 5250
0101 7000 350 7350
2 111-1111 △△県△△市△町 夏野　夏美
2013 5000 250 5250
0101 7000 350 7350
3 222-2222 □□県□□市□□町 秋田　秋夫
2013 5000 250 5250
0101 7000 350 7350
4 333-3333 ××県××市××町 冬川　冬彦
2013 5000 250 5250
0101 7000 350 7350
5 　〃 〃 〃
20130101 5000 250 5250
0101 7000 350 7350
10000　　　〃 〃 〃
20130101 5000 250 5250
0101 7000 350 7350

10000件分コピーして挿入する内容は同じです。
ただ、コピーしたセルの1行目と2行目の並びは変えたくありません。

わかりづらい説明かもしれませんが、宜しくお願いします。

回答No.4

tom04 · ベストアンサー

No.2・3です。
補足を何度読み返してもまだ、理解できていません。

＞Ａ列１行目「通し番号」２行目（コピー挿入したい）「年月」３行目（コピー挿入したい）「101」
＞Ｂ列１行目「郵便番号」２行目（コピー挿入したい）「金額」３行目（コピー挿入したい）「金額」
＞Ｃ列１行目「住所」２行目（コピー挿入したい）「消費税」３行目（コピー挿入したい）「消費税」
＞Ｄ列１行目「名前」２行目（コピー挿入したい）「合計金額」３行目（コピー挿入したい）「合計金額」

と質問文にある、挿入後のデータはすべて同じ！を考えると
↓の画像のような感じになってしまいますが・・・
（これでは意味がないように思えますが、敢えてコードを載せてみます）

※　For～Nextでループさせるとデータ量が多い場合おそらく「応答なし」となると思いますので、
極力、Excelの機能を使ってやっています。
（並び替え・オートフィルタ等）
Sub 行挿入3() 'この行から
Dim endRow As Long, cnt As Long, myArray
endRow = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
Range("A:A").Insert
With Range(Cells(2, "A"), Cells(endRow, "A"))
.Formula = "=row()"
.Value = .Value
.Copy
End With
Do Until cnt = 2
cnt = cnt + 1
Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Loop
Range("A1").CurrentRegion.Sort key1:=Range("A1"), order1:=xlAscending, Header:=xlYes
endRow = Cells(Rows.Count, "A").End(xlUp).Row
With Range(Cells(2, "A"), Cells(endRow, "A"))
.Formula = "=IF(B2="""",IF(B1<>"""",1,2),"""")"
.Value = .Value
End With
With Range("A1")
.AutoFilter field:=1, Criteria1:=1
For cnt = 2 To 5
Range(Cells(2, cnt), Cells(endRow, cnt)).SpecialCells(xlCellTypeVisible) = Cells(1, cnt)
Next cnt
.AutoFilter field:=1, Criteria1:=2
myArray = Array("101", "金額", "消費税", "合計金額")
For cnt = 2 To 5
Range(Cells(2, cnt), Cells(endRow, cnt)).SpecialCells(xlCellTypeVisible) = myArray(cnt - 2)
Next cnt
End With
Range("A:A").Delete
ActiveSheet.AutoFilterMode = False
Application.ScreenUpdating = True
MsgBox "処理完了"
End Sub 'この行まで

※　データ量が10000程度だというコトですので、
そこそこ時間を要すると思います。m(_ _)m

お礼

tom04さん
何度もご返答頂き本当に有難う御座います！
わかりづらい説明で誠に申し訳なくおもっております。
質問に画像添付の仕方がわかりましたので、画像を追加してみました。

まずは、ご教授頂いたマクロで試したいと思います!!
有難う御座います。

回答No.3

tom04

No.2です。

＞10000件分コピーして挿入する内容は同じです
とありますが、質問文では
＞201350002505250　と　2013010150002505250　があり
データが違いますよね？
その辺があるので前回は敢えて挿入するデータを表示させていませんでした。

とりあえずA列だけに15桁で表示させるという前提だと、↓のコードにしてみてください。
挿入行のA列に　201350002505250　を　2行目に　010170003507350　を表示してみました。
1行目は項目行でデータはA列の2行目以降にあるとします。

Sub 行挿入2()
Dim endRow As Long, cnt As Long
endRow = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
Range("A:A").Insert
With Range(Cells(2, "A"), Cells(endRow, "A"))
.Formula = "=row()"
.Value = .Value
.Copy
End With
Do Until cnt = 2
cnt = cnt + 1
Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Loop
Range("A1").CurrentRegion.Sort key1:=Range("A1"), order1:=xlAscending, Header:=xlYes
endRow = Cells(Rows.Count, "A").End(xlUp).Row
With Range(Cells(2, "A"), Cells(endRow, "A"))
.Formula = "=IF(B2="""",IF(B1<>"""",1,2),"""")"
.Value = .Value
End With
With Range("A1")
.AutoFilter field:=1, Criteria1:=1
With Range(Cells(2, "B"), Cells(endRow, "B"))
.SpecialCells(xlCellTypeVisible) = "201350002505250"
.NumberFormatLocal = "000000000000000"
End With
.AutoFilter field:=1, Criteria1:=2
With Range(Cells(2, "B"), Cells(endRow, "B"))
.SpecialCells(xlCellTypeVisible) = "010170003507350"
.NumberFormatLocal = "000000000000000"
End With
End With
Range("A:A").Delete
ActiveSheet.AutoFilterMode = False
Application.ScreenUpdating = True
MsgBox "処理完了"
End Sub

※　あくまで憶測ですが、数値データはいくつかのセルに分けて表示するのではないでしょうか？
とりあえずはこの程度で・・・m(_ _)m

補足

tom04さん

誠に有難うございます。
こんなにも親切に教えて下さるとは思いもよらず、感動しております。
わかりづらい説明で申し訳ありません。

＞201350002505250　と　2013010150002505250　
これは私の記載ミスです。すみません。

tom04さんの憶測通りセルがわかれております。

Ａ列１行目「通し番号」２行目（コピー挿入したい）「年月」３行目（コピー挿入したい）「101」
Ｂ列１行目「郵便番号」２行目（コピー挿入したい）「金額」３行目（コピー挿入したい）「金額」
Ｃ列１行目「住所」２行目（コピー挿入したい）「消費税」３行目（コピー挿入したい）「消費税」
Ｄ列１行目「名前」２行目（コピー挿入したい）「合計金額」３行目（コピー挿入したい）「合計金額」

２行目と３行目は記載内容が異なります。
１００００名分同じ内容で２行目、３行目を１名おきにコピー挿入ができると助かります。

回答No.2

tom04

こんばんは！

行挿入後、どのようなデータを貼り付けるか判らないので
とりあえず行挿入と行削除のコードを載せてみます。

質問文を見る限り、すべて同じデータのようですが、あえてそこは無視しています。
シートモジュールです。

Sub 行挿入()
Dim endRow As Long, cnt As Long
endRow = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
Range("A:A").Insert
With Range(Cells(2, "A"), Cells(endRow, "A"))
.Formula = "=row()"
.Value = .Value
.Copy
End With
Do Until cnt = 2
cnt = cnt + 1
Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Loop
Range("A1").CurrentRegion.Sort key1:=Range("A1"), order1:=xlAscending, Header:=xlYes
Range("A:A").Delete
Application.ScreenUpdating = True
MsgBox "処理完了"
End Sub

Sub 削除()
Dim endRow As Long
endRow = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
Range("A:A").Insert
With Range(Cells(2, "A"), Cells(endRow, "A"))
.Formula = "=IF(B2="""",2,1)"
.Value = .Value
End With
Range("A1").CurrentRegion.Sort key1:=Range("A1"), order1:=xlAscending, Header:=xlYes
Range("A:A").Delete
Application.ScreenUpdating = True
MsgBox "処理完了"
End Sub

※　あとは行挿入後の貼り付けだけですが、具体的なデータを示していただければ
少しはお役に立つと思います。

今回はこの程度で・・・m(_ _)m

回答No.1

sora1515

選択した範囲に２行追加するマクロです。
範囲指定の方法は別途お好きなのに変えて下さい。(xlDownや固定値)

Sub test()
col_1st = Selection(1).Column
col_end = Selection(Selection.Count).Column
row_1st = Selection(1).Row
row_end = Selection(Selection.Count).Row + 1

For i = row_end To row_1st + 1 Step -1
Range(Cells(i, col_1st), Cells(i, col_end)).Insert xlShiftDown
Range(Cells(i, col_1st), Cells(i, col_end)) = "'010170003507350"
Range(Cells(i, col_1st), Cells(i, col_end)).Insert xlShiftDown
Range(Cells(i, col_1st), Cells(i, col_end)) = "'201350002505250"
Next i

End Sub

ps
追加行を数えず処理するにはやはり最終行からの処理が楽でしょうか。