質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

90.03%

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

解決済

回答 1

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 2,020

emon2525

score 6

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

エクセルのマクロ(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
  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 1

checkベストアンサー

0

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

Option Explicit

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    '追加する行数の中に既に空白行があったらその行数分
    Dim k As Long

    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 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  '選択された行数分追加
                For k = 1 To AddCnt
                    Rows(i + k).Value = Rows(i).Value
                Next
            End If
            cntBlank = 0
        Case Else
            cntBlank = 0
        End Select
    Next i

    Application.ScreenUpdating = True
End Sub

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2018/10/15 10:40

    tatsu99 さま

    早々にご回答いただきありがとうございます!!

    コピー部分拝見しました。
    なるほど!といって形で理解しているわけでない素人ですが

    記述いただいた
    Dim k As Long・・・
    の部分を自分なりに調べて理解できればと思います。

    ご回答いただいた内容で 思い通りの動作になりましたので感激です。
    ありがとうございます。


    ------
    1.最終行はA列を基準にして決めた方がよいような気がします。
    2.B列が空白の時、どのような結果を期待しているのかが不明。
    ------
    1.に関しまして承知しました。こちら調べまして変更できればとおもいます。
    アドバイスいただきありがとうございます。

    Case Is >= 2 → 1

    2.に関しまして
    現段階では Bの値は絶対ある ので問題ないです。
    先ほど空白時を検証したのですが
    空白時は何もならないので 一応希望する動作になっております。。。
    (VBA的に良くない等はわからないのですが。。)

    ご丁寧にソースの記述+アドバイス+指摘いただき勉強になります。
    本当にありがとうございました。m(__)m

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 90.03%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる