同じレコード単位で纏めて、違うレコードとの間に行挿入をしたい。

同じレコード単位で纏めて、違うレコードとの間に行挿入をしたい。

Ａ列～Ｄ列まで入力されて１０００行あります。
Ａ列を基準にソート済みなので以下のようになります。

　　Ａ列　　Ｂ列　Ｃ列　Ｄ列
A1　123　　　AA　　BB　　CC
A2　123　　　DD　　BB　　CC
A3　123　　　DD　　EE　　CC　
A4　456　　　FF　　GG　　HH
A5　456　　　JJ　　KK　　CC
A6　789　　　JJ　　LL　　MM
A7　789　　　NN　　PP　　QQ
A8　789　　　RR　　PP　　CC

これでA列の値が相違する場合そこに空白行を挿入したいです。

　　Ａ列　　Ｂ列　Ｃ列　Ｄ列
A1　123　　　AA　　BB　　CC
A2　123　　　DD　　BB　　CC
A3　123　　　DD　　EE　　CC　
A4
A5　456　　　FF　　GG　　HH
A6　456　　　JJ　　KK　　CC
A7
A8　789　　　JJ　　LL　　MM
A9　789　　　NN　　PP　　QQ
A10　789　　　RR　　PP　　CC

これを１０００行手作業で行うのは大変なので一括で行いたいです。
方法はありますでしょうか？
お願いします。

No.1 ベストアンサー 回答者： merlionXX 回答日時： 2010/08/26 17:09

マクロでやるしかないと思います。

現在は途中に空白行がないという前提でマクロを作成しました。
簡単ですので試してください。
ただし、オリジナルデータは控えをとってからにしましょう。（万一失敗したときの用心）
手順は以下のとおりです。

1.データがあるシートを開いたままで、AltキーとF11キー同時に押し（以下Alt+F11キーと記述）て Visual Basic Editor を呼び出します。
2.Visual Basic Editor のメニューから「挿入」、「標準モジュール」で出てきたコードウィンド（右側の白い広い部分）に以下のコード（Sub～End Sub）をコピペします。

'********これより下**********

Sub test01()
　　Dim myC As Range
　　Set myC = Range("A1") '当初対象セル
　　Do While myC <> "" 'データがある限り
　　　　Set myC = myC.Offset(1) '対象セルを1個繰下
　　　　If myC.Value <> myC.Offset(-1) Then '一つ上のセルと異なる値なら
　　　　　　If myC.Offset(-1).Value <> "" Then '一つ上のセルが空白でなければ
　　　　　　　　myC.EntireRow.Insert '1行挿入
　　　　　　End If
　　　　End If
　　Loop
End Sub

'********これより上**********

3.Alt+F11キーでワークシートへもどります。
4..Alt+F8キーで出てきたマクロ名（test01）を選択して実行します。

この回答へのお礼

すばらしいです。
完璧にできました。
１０，０００行でもチャレンジしましたが
できました。どうもありがとうございました。

お礼日時：2010/08/27 11:49

No.3 回答者： MackyNo1 回答日時： 2010/08/26 22:22

一般機能を利用してデータの変わり目に空白行を一括挿入するには以下のような操作をします。

補助列のE２セルに「=IF(A2<>A1,1,"")」と入力し、E2セルの右下部分をダブルクリックして数式をオートフィルコピーし、挿入する行の位置に「１」と表示させます。
そのままE2セルから数式が入力されている範囲を選択した状態で、Ctrl+Fのショートカット操作から「オプション」ボタンをクリックし検索対象を「値」にして「すべて検索」し、Ctrｌ+Aのショートカット操作で対象セルをすべて選択し、選択セルの上で右クリックし、「挿入」から「行全体」でOKすれば、すべてのデータの区切りに空白行が挿入されます。
最後に補助列を選択して、Deleteすれば完成です。

この回答へのお礼

マクロでなくてもできるんですね。
ですが、常に使用していないと
覚えてられないかもしれません。
どうもありがとうございました。

お礼日時：2010/08/30 11:06

No.2 回答者： tom04 回答日時： 2010/08/26 20:58

こんばんは！

すでに回答は出ていますので参考程度で・・・

ごくごく単純にやってみました。

Sub test()
Dim i As Long
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If Cells(i, 1) <> Cells(i - 1, 1) Then
Rows(i).Insert (xlDown)
End If
Next i
End Sub

参考になれば幸いです。m(__)m

この回答へのお礼

すばらしいです。完璧です。
ありがとうございました。

お礼日時：2010/08/30 10:49