EXCEL VBA 条件による行の自動挿入

お世話になります。

EXCEL VBAを使用して自動で行の挿入処理を実施したいと思っております。

やりたい事は添付図の表1を処理ボタンを押せば自動で表2のようにしたいのです。
表2の黄色部分が自動挿入させたい部分です。


例えば「表2作成」というボタンを押したら・・

[sheet1]にある表1をC1からC??の最終行までREADしてC??の文字列が
[定価番販売実績]であれば・・
(1)[定価販売実績]の上の行に[定価販売予定]という行を挿入
(2)[定価販売実績]の下の行に[定価差異]という行を挿入

[得売販売実績]であれば・・
(3)[特売販売実績]の上の行に[特売販売予定]という行を挿入
(4)[特売販売実績]の下の行に[特売差異]という行を挿入

という作業を全商品に対して実施したいのです。
図では3商品ですが実際には変動ですが100～200品位です。

出来上がった新しい表2は別シートに表示できれば最高です！

どなたか方法をご教授いただけませんでしょうか？
よろしくお願い致します。

環境
Windows XP SP3
EXCEL2003

No.1 回答者： KURUMITO 回答日時： 2013/05/13 17:02

その程度のことでしたら関数を使って対応できますね。

シート1のＡ1セルからＣ1セルには項目名が有り、お示しのような表が有るとします。
そこでシート2にはＡ1セルからＣ1セルにはシート1と同じ項目名を並べたのちにＡ2セルには次の式を入力し、Ａ2セルからＡ7セルを選択してセルの結合を行ってから下方にドラッグコピーします。

=IF(ROW(A1)>(COUNTA(Sheet1!$A:$A)-1)*6,"",IF(COUNTIF(A$1:A1,INDEX(Sheet1!$A:$A,ROUNDUP(ROW(A1)/6,0)*2))>0,"",INDEX(Sheet1!$A:$A,ROUNDUP(ROW(A1)/6,0)*2)))

Ｂ2セルには次の式を入力して下方にドラッグコピーします。

=IF(ROW(A1)>(COUNTA(Sheet1!$A:$A)-1)*6,"",IF(MOD(ROW(A1)-1,6)+1=2,INDEX(Sheet1!$B:$B,MATCH(OFFSET($A2,-1,0),Sheet1!$A:$A,0)),IF(MOD(ROW(A1)-1,6)+1=5,INDEX(Sheet1!$B:$B,MATCH(OFFSET($A2,-4,0),Sheet1!$A:$A,0)+1),"")))

Ｃ2セルには次の式を入力して下方にドラッグコピーします。

=IF(ROW(A1)>(COUNTA(Sheet1!$A:$A)-1)*6,"",CHOOSE(MOD(ROW(A1)-1,6)+1,"定価販売予定","定価販売実績","定価差異","特価販売予定","特価販売実績","特価差異"))

この回答への補足

KURUMITOさん、早速のご連絡ありがとうございます！

出来ました！すごい感動しました!!

しかし、ご教授いただきました下記の数式で、特定の数箇所のSheet1のA??セルの商品名が参照できず、ブランクで表示されてしまっています・・とびとびでブランク表示になるのでsheet1のA??の商品名データに何か原因があるかと思いましたが特に変か所も見当たりません。

ご教授いただきました数式が高度すぎて私の頭では理解できず、どこをどう確認していいのか分かりません。
そこで、下記数式について簡単で結構ですのでご説明いただけませんでしょうか？
なぜ数字の切り上げ時に使うROUNDUPがこの式に必要なのかか理解が出来ないのです・・(泣)。お手数をおかけしまして大変申し訳ありませんが何卒よろしくお願い致します。

=IF(ROW(A1)>(COUNTA(Sheet1!$A:$A)-1)*6,"",IF(COUNTIF(A$1:A1,INDEX(Sheet1!$A:$A,ROUNDUP(ROW(A1)/6,0)*2))>0,"",INDEX(Sheet1!$A:$A,ROUNDUP(ROW(A1)/6,0)*2)))

補足日時：2013/05/13 20:46

No.2 ベストアンサー 回答者： tom04 回答日時： 2013/05/13 20:35

こんばんは！

VBAでの一例です。
画像通り1行目は項目行で、データは2行目以降にあるとします。
画像を拝見するとA列は結合してあるようですね！

＞処理ボタンを押せば自動で・・・
とありますので、操作したいSheetにコマンドボタンを配置するとします。
↓のコードをコピー＆ペーストしてコマンドボタンをクリックしてみてください。
コマンドボタンでなくても
メニュー　→　挿入　→　オートシェイプ　→　挿入したオートシェイプ上で右クリック　→　マクロの登録　→　新規作成
このVBE画面でも構いません

Private Sub CommandButton1_Click() 'この行から
Dim i As Long, k As Long
Range("A:A").UnMerge
For i = 2 To Cells(Rows.Count, 2).End(xlUp).Row
If Cells(i, 1) = "" Then
Cells(i, 1) = Cells(i - 1, 1)
End If
Next i
For i = Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1
If Cells(i, 3) = "定価販売実績" Then
Rows(i + 1).Insert
Cells(i + 1, 3) = "定価販売差異"
Cells(i + 1, 1) = Cells(i, 1)
Rows(i).Insert
Cells(i, 3) = "定価販売予定"
Cells(i, 1) = Cells(i + 1, 1)
ElseIf Cells(i, 3) = "特売販売実績" Then
Rows(i + 1).Insert
Cells(i + 1, 3) = "特売販売差異"
Cells(i + 1, 1) = Cells(i, 1)
Rows(i).Insert
Cells(i, 3) = "特売販売予定"
Cells(i, 1) = Cells(i + 1, 1)
End If
Next i
Application.DisplayAlerts = False
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If Cells(i, 1) = Cells(i - 1, 1) Then
Range(Cells(i - 1, 1), Cells(i, 1)).Merge
End If
Next i
Application.DisplayAlerts = True
End Sub 'この行まで

※　1行目と最終行は
コマンドボタンを挿入　→　挿入したコマンドボタン上でダブルクリックすると自動で表示されますので、
ダブらないようにコードをコピー＆ペーストしてみてください。

尚、一旦コマンドボタンをクリックすると元に戻せませんので
別Sheetで試してみてくだい。m(_ _)m

この回答への補足

tom04さん、おはようございます！
早速のご連絡ありがとうございました！！

出来ました！！すごいです！

しかし、定価販売差異と特売販売差異が挿入されませんでした。。あとこの2つが挿入されれば完成なのですが・・。

私の環境が悪いのかもしれませんが、再度ご教授いただけあｍせんでしょうか？
本当に度々申し訳ございません。

補足日時：2013/05/14 09:05

この回答へのお礼

tom04さん、申し訳ございません。

さきほどの補足は私の勘違いで、ちゃんと出来ました！

大変失礼いたしました。
詳細なコードのご提示、本当にありがとうございました！

とても勉強になりました。

お礼日時：2013/05/14 09:46