EXCEL VBA条件による行の上下段へのコピー

質問

EXCEL VBA 条件による上や下段への行コピー
お世話になります。

質問させていただきます。

添付図ようなの表1があります。
この表は各商品につき6行あって[品名]と[区分]だけは6行すべてデータが入っていますが、その他の[納品日]や[担当者]フィールドには6行全てには入っていません。(ピボットテーブルで集計した表のため)

このほうが表としては見易くて良いのですが、オートフィルターをかけると空白行が抽出されずに不便で困っています。

そこで表1を表2のように全ての行にデータを入れればオートフィルターでもうまく抽出できるので、このようにしたいのです。(表2の緑色セル部分)

以下表1の条件です
(1)品名、区分は必ず入っている
(2)品番は各商品データの2行目(1行目ではなく)に必ず入っている
(3)納品日～問屋名までは同一データが続く場合、先頭データの2行目(1行目ではなく)にしか入っていない
(4)商品データは1商品につき6行表示されていて、可変ですが1000行ほどあります

やりたい事・・・
[データ挿入]というボタンを作成して、ボタンを押したら表1が表2の緑色セルを埋めるような動作をさせたいです

お忙しいところ恐縮ですがどなたかお知恵をお借りできますでしょうか？
何卒よろしくお願い致します。

環境
Windows XP SP3
Excel2003

回答No.2

tom04 · ベストアンサー

こんにちは！
一例です。

Sub Sample1()
Dim i As Long, j As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next '←おまじない
For i = 2 To Cells(Rows.Count, "G").End(xlUp).Row Step 6
For j = 1 To 6
Cells(i, j).Resize(6, 1).Merge
If Cells(i, j) = "" Then
Cells(i, j) = Cells(i - 1, j)
End If
Cells(i, j).Resize(6, 1).UnMerge
Cells(i + 1, j).Resize(5, 1) = Cells(i, j)
Next j
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

こんなんではどうでしょうか？m（_ _）m

お礼

tom04さん、早速のご連絡ありがとうございます！
いつも本当にありがとうございます！！

ご教授いただきました方法で実現できました！!

何度も何度もお時間をさいていただきまして本当にありがとうございました。

これから少しづつでもご教授いｔだきました様なロジックが組めるように勉強していきたいと思います。

本当にありがとうございました！m（_ _）m

回答No.1

FEX2053

たぶんよりかっこいいコードがあると思うんですが、私のポリシー
として、「後でメンテがしやすい、可能な限り簡単なコード」って
のがありまして・・・。

Sub test()
Dim DAT_N(7) As Variant
Dim i, j As Integer
Range("G3").Select
Do
For i = 0 To 6
If Selection.Offset(0, -i) <> "" Then
DAT_N(i + 1) = Selection.Offset(0, -i).Value
End If
Next
For j = -1 To 4
If Selection.Offset(j, 1).Value = "" Then Exit Sub
For i = 0 To 6
Selection.Offset(j, -i).Value = DAT_N(i + 1)
Next
Next
Selection.Offset(6).Select
Loop
End Sub

たぶんこれでできると思います。

お礼

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

ご教授いただきました方法で実現できました！!

この度は素人同然の私にも分かり易いコードのご提示誠にありがとうございました!

本当にありがとうございました！m（_ _）m