セルに入力された数値で行を挿入

初めて投稿します。
よろしくお願いいたします。

エクセルのマクロ（VBA）について実現できないか質問です。

図のように

①に入力された値がありまして　行数の値をもとに
②のように展開したいのですが実現可能でしょうか。

行数に入ってる値をもとに行を挿入しコピーを行いたいと思っております。

何か参考になる記事かこちらの仕様に関してアドバイスの程、、よろしくお願いいたします。

追記でございます。
ここまでは　他の回答を参考に実現できております。
行は挿入できるものの　コピーも同時に実行したいと考えております。
ご教授いただけると幸いです。

Sub InsertRow1()

    Dim i As Long
    Dim intStart As Long
    Dim intCol As Long
    Dim cntBlank As Long
    Dim AddCnt As Long
    Dim msg_1 As String



    intStart = 2   '開始する行数
    intCol = 2    '数字を読み込む列
    i = intStart    '追加する行数の先頭位置
    Dim j As Integer    '追加する行数の中に既に空白行があったらその行数分


    msg_1 = "B列に指定されている変数分追加しますか？"

    If MsgBox(msg_1, vbYesNo) = vbNo Then Exit Sub        '行を追加してよいかのポップアップを出す

    Application.ScreenUpdating = False  '処理終了まで画面表示はそのまま

    '最終行の1行上から上へ読み込む
    For i = Cells(Rows.Count, intCol).End(xlUp).Row - 1 To intStart Step -1
        Select Case Cells(i, intCol).Value
        Case ""
            cntBlank = cntBlank + 1 '空白行カウント
        Case Is >= 2
            AddCnt = Cells(i, intCol).Value - cntBlank  '追加する行数計算
            'AddCnt = Cells(i, intCol).Value - cntBlank - 1  '追加する行数計算
            If AddCnt > 0 Then
                Range(Rows(i + 1), Rows(i + AddCnt)).Select
                Selection.Insert  '選択された行数分追加
            End If
            cntBlank = 0
        Case Else
            cntBlank = 0
        End Select
    Next i

    Application.ScreenUpdating = True
End Sub

行動規範の内容に同意します

回答1件

ベストアンサー

＞行は挿入できるものの　コピーも同時に実行したいと考えております。
とりあえず、コピーの部分を追記しました。
気がかりなのは、
１．最終行はA列を基準にして決めた方がよいような気がします。
２．B列が空白の時、どのような結果を期待しているのかが不明。

VBA
1Option Explicit
2
3Sub InsertRow1()
4
5    Dim i As Long
6    Dim intStart As Long
7    Dim intCol As Long
8    Dim cntBlank As Long
9    Dim AddCnt As Long
10    Dim msg_1 As String
11
12
13
14    intStart = 2   '開始する行数
15    intCol = 2    '数字を読み込む列
16    i = intStart    '追加する行数の先頭位置
17    Dim j As Integer    '追加する行数の中に既に空白行があったらその行数分
18    Dim k As Long
19
20    msg_1 = "B列に指定されている変数分追加しますか？"
21
22    If MsgBox(msg_1, vbYesNo) = vbNo Then Exit Sub        '行を追加してよいかのポップアップを出す
23
24    Application.ScreenUpdating = False  '処理終了まで画面表示はそのまま
25
26    '最終行の1行上から上へ読み込む
27    For i = Cells(Rows.count, intCol).End(xlUp).Row To intStart Step -1
28        Select Case Cells(i, intCol).Value
29        Case ""
30            cntBlank = cntBlank + 1 '空白行カウント
31        Case Is >= 2
32            AddCnt = Cells(i, intCol).Value - cntBlank  '追加する行数計算
33            'AddCnt = Cells(i, intCol).Value - cntBlank - 1  '追加する行数計算
34            If AddCnt > 0 Then
35                Range(Rows(i + 1), Rows(i + AddCnt)).Select
36                Selection.Insert  '選択された行数分追加
37                For k = 1 To AddCnt
38                    Rows(i + k).Value = Rows(i).Value
39                Next
40            End If
41            cntBlank = 0
42        Case Else
43            cntBlank = 0
44        End Select
45    Next i
46
47    Application.ScreenUpdating = True
48End Sub

投稿2018/10/15 00:57

tatsu99

総合スコア5493

emon2525

2018/10/15 01:40

tatsu99　さま早々にご回答いただきありがとうございます！！コピー部分拝見しました。なるほど！といって形で理解しているわけでない素人ですが記述いただいた Dim k As Long・・・の部分を自分なりに調べて理解できればと思います。ご回答いただいた内容で　思い通りの動作になりましたので感激です。ありがとうございます。 ------ １．最終行はA列を基準にして決めた方がよいような気がします。２．B列が空白の時、どのような結果を期待しているのかが不明。 ------ 1.に関しまして承知しました。こちら調べまして変更できればとおもいます。アドバイスいただきありがとうございます。 Case Is >= 2　→　1 2.に関しまして現段階では　Bの値は絶対ある　ので問題ないです。先ほど空白時を検証したのですが空白時は何もならないので　一応希望する動作になっております。。。（VBA的に良くない等はわからないのですが。。）ご丁寧にソースの記述＋アドバイス＋指摘いただき勉強になります。本当にありがとうございました。m(__)m

行動規範の内容に同意します