エクセルで表示された値だけ行数をコピーし挿入、挿入行の指定したセルに連続した値を表示できますか？

Question

エクセルで、データの右端の列に表示されている、別のシートからVLOOKUPで返した数値の行数を、数値が表示された行をコピーしてそのすぐ下に挿入し、更に、コピーした行の指定したセルの値を【10倍してプラス１】した数値をデータの一番右の列に表示させ、挿入した行だけにその連続した値を表示させたデータを別シートに作成することは可能でしょうか？

添付しました写真の【Ｑ】列に表示された値の行数だけ、コピーしてすぐ下に挿入（＃Ｎ/Aは０とする）し、【I】列『商品コード』の数値×10＋1の数値を、コピー元の行の【Ｓ】列に表示、挿入行にのみそれぞれにその数値の連続した値を表示させたデータを、シート２（補足で添付致します）に表示させたいのです。（4行目が項目、データは5行目からです。）

セットコードで入力されたデータを、セットの内訳をすべて表示させたデータにする事が目的ですが、データの量が1000件近くなるかもしれず、手作業では無理なため試行錯誤しておりますがどうしてもうまくいきません。
挿入した行へ、セット内訳の商品コード・商品名・価格等を、また別シートからVLOOKUPで返す予定です。
VBAにお詳しい方、どうかどうか宜しくお願い致します。

tatsu99 · Accepted Answer

以下のマクロを標準モジュールに登録してください。
Sheet2の挿入＆コピーを行います。予めSheet2に関数を埋め込むということなので、
Sheet2のＴ列より右側は一切マクロでは更新しません。
Sheet2の4行目以降のＡ列からＳ列はSheet1の内容がコピーされるか、マクロにより内容が設定されるため、そこに関数を埋め込んではいけません。
----------------------------------------------------------
Option Explicit
Public Sub 挿入コピー()
    Dim maxrow1 As Long
    Dim maxrow2 As Long
    Dim row1 As Long
    Dim row2 As Long
    Dim i As Long
    Dim val As Variant
    Dim copy_count As Long
    Dim rng1 As Variant
    Dim rng2 As Variant
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Set sh1 = Worksheets("Sheet1")
    Set sh2 = Worksheets("Sheet2")
    maxrow1 = sh1.Cells(Rows.Count, 1).End(xlUp).Row    'sheet1の最大行取得
    maxrow2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row    'sheet2の最大行取得
    sh2.Range("A4:R4").Value = sh1.Range("A4:R4").Value
    If maxrow2 > 4 Then
        sh2.Range("A5:S" & maxrow2).ClearContents
    End If
    row2 = 5
    For row1 = 5 To maxrow1
        val = sh1.Cells(row1, "Q").Value
        If IsNumeric(val) = False Then
            copy_count = 0
        Else
            copy_count = val
        End If
        rng1 = "A" & row1 & ":R" & row1
        rng2 = "A" & row2 & ":R" & row2
        sh2.Range(rng2).Value = sh1.Range(rng1).Value
        row2 = row2 + 1
        For i = 1 To copy_count
            rng2 = "A" & row2 & ":R" & row2
            sh2.Range(rng2).Value = sh1.Range(rng1).Value
            sh2.Cells(row2, "S").Value = sh1.Cells(row1, "I").Value * 10 + i
            row2 = row2 + 1
        Next
    Next
    MsgBox ("完了")
End Sub

nouble1 · Answer

此方も、
http://officetanaka.net/excel/vba/tips/

nouble1 · Answer

お役に　立てたなら、
幸いです。

tatsu99 · Answer

補足要求です。
①コピーはSheet1のA～R列をそのままSheet2のA～R列へコピーすれば良いのですか？
（行の追加は②で行います。Q列の値がN/Aの場合でも行う１行分のコピーについてです）

②行をQ列の値の分、追加する時ですが、（例としてQ列の値が6なら）
Sheet1のA～R列をそのままSheet2のA～R列へコピーする。（6回行う）
Sheet2のS列は、Aheet1のI列×１０＋Ｎとする。
（Ｎは１回目のコピーの時１、２回目のコピーの時２、・・・６回目のコピーの時６とする）

上記①②の考え方であってますか。

③Sheet1のＱ列の値が10以上になることはあるのですか？
質問の意図は、もし、あるなら（Ｑ列の値＝１２とすると）、
Ｉ列のコードが１００の時、Ｓ列へ設定する１２回目の値は、１０００＋１２＝１０１２になる
がそれで良いのかということです。

④「挿入した行へ、セット内訳の商品コード・商品名・価格等を、また別シートからVLOOKUPで返す予定です。」とあるが、
これは、VBAでSheet2を作成したあとで、あなたが、Sheet2へVLOOKUPの関数式を埋め込むということでしょうか。
もし、そうなら、その作業は結構大変かと思いますが・・・・

nouble1 · Answer

なら、
Excelには、
行動を　記録し、
マクロ化する、
機能が　あるから、

Excel自身に、
教えて貰えば　いいよ。

記録する
https://www.forguncy.com/blog/20170726_macro

此　読んでね、

参考図書
http://www.asahi-net.or.jp/~ef2o-inue/menu/menu04.html

nouble1 · Answer

あっと！
ユニオンメソッドの　説明は、
此方ですよ、
https://docs.microsoft.com/ja-jp/office/vba/excel/concepts/cells-and-ranges/refer-to-multiple-ranges

nouble1 · Answer

尚、
サブルーティンにて、
Find等を　持ちい、
数値を　探させ、

Union メソッドで、
見つかった　セル等を、
統合指定して、

全て　一気に、
探し出させ、

一つと　して、
返させ、

下方から　順に、
以下の　配下に、
挿入させていけば、

着目点には　挿入行為の、
影響が　及ばず、

効率的な　作業が、
望めるものと　思いますよ。

nouble1 · Answer

再帰的に　なりそうですね、
挿入する列にも、
値記載が　あった場合、
どう扱うのですか？

S列は　フィルさせれば、
十分でしょう、

VLOOKUPは　もう出来るのですよね？
Evaluateか、WorksheetFunctionを、
持ちいれば、
問題無い事と　思います。

コピ等は　言及するまでも、
ないですよね？

演算も　出来ますよね？

後は、
組み立てるだけでは？

nouble1 · Answer

失礼、
導入権限を　お持ちなのですね。

nouble1 · Answer

誰もが　答える前に、
お伺いします、

貴方は　其のシステムに、
VBAを　入れる事を、
許されますか？

尚、
許可無く　入れた場合、
解雇理由として、
必要十分な程の　重要案件なのですが。

何故なら、
悪意のあるプログラムも、

しばしば、
VBAの　形を、
取り得るからで、

其れ等は、
アンチウイルスソフトに、
掛からない事が　多く、

故に、
悪質に　見られる訳です。

エクセルで表示された値だけ行数をコピーし挿入、挿入行の指定したセルに連続した値を表示できますか？

以下のマクロを標準モジュールに登録してください。

此方も、

お役に 立てたなら、

補足要求です。

なら、

あっと！

尚、

再帰的に なりそうですね、

失礼、

誰もが 答える前に、

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

お役に　立てたなら、

再帰的に　なりそうですね、

誰もが　答える前に、