【excle VBA】抜け番号の空白の行を自動に挿入したい

質問

欠品のある月は、月の番号を挿入するのと、できれば商品名だけコピーして埋めて、あとは空白の行を挿入したいのです。

ただし、何月に欠品しているかは商品ごとに異なり、３月のＢ列に確実にあるわけではないです。しかし３月～１２月のうちのどこかの月には確実にあります。

また、今回は１２月までですが、今後１３月（１月）、１４月（２月）まで登場します。が、今回は１２月までがいいのです。できましたら、１３月、１４月と増えた場合の対応も教えていただけると幸いです。

商品は何千点とあるので、相対参照で行いたいです。

≪現在の表≫
－－－－－－－－－－
Ａ　　　　　　Ｂ　　　　　　Ｃ　　　　　　Ｄ
月　　　　　商品　　　　価格　　　　割引
３　　　　　牛乳　　　　１００円　　　　５％
４　　　　　牛乳　　　　１２０円　　　　３％
６　　　　　牛乳　　　　１１２円　　　　４％
１０　　　　牛乳　　　　１００円　　　　５％
４　　　　　卵　　　　　　１００円　　　　５％
５　　　　　卵　　　　　　１２０円　　　　３％
８　　　　　卵　　　　　　１１２円　　　　４％

－－－－－－－－－－
↓　↓　↓

≪理想の表≫
－－－－－－－－－－
Ａ　　　　　　Ｂ　　　　　　Ｃ　　　　　　Ｄ
月　　　　　商品　　　　価格　　　　割引
３　　　　　牛乳　　　　１００円　　　　５％
４　　　　　牛乳　　　　１２０円　　　　３％
５　　　　　牛乳
６　　　　　牛乳　　　　１１２円　　　　４％
７　　　　　牛乳
８　　　　　牛乳
９　　　　　牛乳
１０　　　　牛乳　　　　１００円　　　　５％
１１　　　　牛乳
１２　　　　牛乳
３　　　　　卵
４　　　　　卵　　　　　　１００円　　　　５％
５　　　　　卵　　　　　　１２０円　　　　３％
６　　　　　卵
７　　　　　卵
８　　　　　卵　　　　　　１１２円　　　　４％
９　　　　　卵
１０　　　　卵
１１　　　　卵
１２　　　　卵
－－－－－－－－－－
長い表ですいませんっ。

過去の質問で似たものがあったのですが、「６」までで、A1に固定されており、私の力では応用できなかったので、改めて質問させていただきます。【参考↓】
http://oshiete1.goo.ne.jp/qa2099951.html

回答No.1

zap35 · ベストアンサー

結構面倒な処理になりました。
質問文の説明がよく理解できないので期待する結果にならないかもしれません。またＡ列の月は日付型ではなく単純に整数が入力されているものと想定しています。
最大月数を変えるには２行目を変更してください

Sub Macro1()
Const mMax As Integer = 12 '最大月数を指定する
Dim m, ptr As Integer
Dim goods As String
　　Application.ScreenUpdating = False
　　ActiveSheet.Copy Before:=ActiveSheet
　　m = mMax
　　goods = Range("B65536").End(xlUp).Value
　　For ptr = Range("A65536").End(xlUp).Row To 1 Step -1
　　　　If Cells(ptr, "B").Value = goods Then
　　　　　　Do While Cells(ptr, "A").Value < m
　　　　　　　　Call rtn(m, goods, ptr)
　　　　　　　　m = m - 1
　　　　　　Loop
　　　　Else
　　　　　　Do While m > 0
　　　　　　　　Call rtn(m, goods, ptr)
　　　　　　　　m = m - 1
　　　　　　Loop
　　　　　　m = mMax
　　　　　　goods = Cells(ptr, "B").Value
　　　　　　Do While Cells(ptr, "A").Value < m
　　　　　　　　Call rtn(m, goods, ptr)
　　　　　　　　m = m - 1
　　　　　　Loop
　　　　End If
　　　　If ptr > 1 Then
　　　　　　m = Cells(ptr, "A").Value - 1
　　　　End If
　　Next ptr
　　Application.ScreenUpdating = True
End Sub

Sub rtn(ByVal m As Integer, goods As String, ptr As Integer)
　　Rows(ptr + 1).Insert
　　Cells(ptr + 1, "A").Value = m
　　Cells(ptr + 1, "B").Value = goods
End Sub

結果はこうなりました

月　　商品　　　価格　　　　　割引
1　　　牛乳
2　　　牛乳
3　　　牛乳　　１００円　　　5%
4　　　牛乳　　１２０円　　　3%
5　　　牛乳
6　　　牛乳　　１１２円　　　4%
7　　　牛乳
8　　　牛乳
9　　　牛乳
10　　　牛乳　　１００円　　　5%
11　　　牛乳
12　　　牛乳
1　　　卵
2　　　卵
3　　　卵
4　　　卵　　　１００円　　　5%
5　　　卵　　　１２０円　　　3%
6　　　卵
7　　　卵
8　　　卵　　　１１２円　　　4%
9　　　卵
10　　　卵
11　　　卵
12　　　卵

お礼

ありがとうございます！！！できました。
とても複雑なマクロを作成していただきまして、誠にありがとうございます！
一気に仕上げるようにしていただけました。
ちなみに、１（月）からではなく、３（月）からにしたいのですが、どちらを変更すればできますでしょうか。

回答No.2

zap35

＃０１です
＞３（月）からにしたいのですが、
１６行目を以下に置き換えればよいです。
　　　Do While m > 2

別の方法でも考えてみました。こちらの方が考え方がシンプルになり、その分処理も速いと思います。

Sub Macro2()
Const mMax As Integer = 12 '最大月数を指定する
Const fMonth As Integer = 3 '開始月
Dim m, ptr As Integer, goods As String
Dim sh As Worksheet, r As Range
　　Application.ScreenUpdating = False
　　Set sh = ActiveSheet
　　Worksheets.Add Before:=ActiveSheet
　　sh.Rows(1).Copy Range("A1")
　　With sh
　　　　For ptr = .Range("A65536").End(xlUp).Row To 2 Step -1
　　　　　　If .Cells(ptr, "B").Value <> goods Then
　　　　　　　　goods = .Cells(ptr, "B").Value
　　　　　　　　Rows("2:" & mMax - fMonth + 2).Insert
　　　　　　　　Range("A2").Value = fMonth
　　　　　　　　Range("A2").AutoFill Destination:=Range("A2").Resize(mMax - fMonth + 1), Type:=xlFillSeries
　　　　　　　　Range("B2").Resize(mMax - fMonth + 1).Value = goods
　　　　　　End If
　　　　　　Set r = Range("A2").Resize(mMax - fMonth + 1).Find(what:=.Cells(ptr, "A").Value, _
　　　　　　　　　　　　LookIn:=xlValues, Lookat:=xlWhole)
　　　　　　If Not r Is Nothing Then
　　　　　　　　.Cells(ptr, "C").Resize(1, 2).Copy r.Offset(0, 2)
　　　　　　End If
　　　　Next ptr
　　End With
　　Application.ScreenUpdating = True
End Sub

お礼

さらに提案いただきありがとうございます！
macro2で行ってみました。おっしゃるとおり早かったです。しかしD列までのコピーで実際はAZ列ぐらいまでのデータなので、そこを変更する仕方が分からず・・・macro1の　>>Do While m > 2　を変更して利用することができました！

zap35先生、本当にありがとうございました！