【VBA】【マクロ】 指定の条件で、空白の行を挿入

はじめまして。
自身で作成しようかと思いましたが、うまくいかず、こちらに相談した次第です。

A列の数字を上から確認して、値があるとき、その値分の空白の行を挿入したいです。

もし、お分かりになる方がおられましたら、ご教示の程お願いいたします。
どうぞよろしくお願いいたします。



以下、例
・実行前
A列
-----------

1

2

-----------

・実行後
A列
-----------

1


2



-----------
以上です。

No.2 ベストアンサー 回答者： Qchan1962 回答日時： 2023/12/04 15:04

＞「0」という表示があると、エラー400になりました。

空白で考えてしまいましたが0はResize(0)でダメですね

＞実行する前に、「0」を消す・非表示などにすれば
実行条件を検討してみてください

セル値が数値であり１以上にする場合の例

If IsNumeric(Cells(i, 1)) And Cells(i, 1) >= 1 Then
Cells(i, 1).Offset(1).Resize(Int(Cells(i, 1))).EntireRow.Insert
End If

Intは小数であった場合の整数部分で挿入行数にしています
他に考えられるエラーもありますので　検証条件を加えるか
Excelの仕様範囲の数値で使う必要があります

この回答へのお礼

検証したところ、「0」という表示があっても、問題なく実行できました。

お礼日時：2023/12/05 08:31

No.5 回答者： Qchan1962 回答日時： 2023/12/05 11:40

#1#2です

検証およびお礼ありがとうございます
初めてのご質問者でしたので回答へのレスがあるかわからなかったので
説明抜きで回答しました。失礼しました

＞A列の数字を上から確認して、値があるとき、その値分の空白の行を挿入したいです。

＃１の回答はご質問手順（上から）に沿った回答ではありません
もし、手順のように処理を進めると　一例として

Sub test2()
Dim lastRow As Long, n As Long
Do
n = n + 1
With ActiveSheet.Cells(n, 1)
If IsNumeric(.Value) And .Value >= 1 Then
.Offset(1).Resize(.Value).EntireRow.Insert
n = n + .Value
End If
End With
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Loop Until n > lastRow
End Sub

のような感じになります

繰り返し処理によるExcelシートの行列挿入（削除）は基本的には＃１のように最終行（最右列）より上部（左）に処理を行います
For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
これにより追加（削除）で変化する処理行および最終行（最右列）に対応します
ここが躓きポイントだと思います

上の処理では変化する最終行を繰り返し処理の度に取得して繰り返し処理の継続判断をしています
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Loop Until n > lastRow
また挿入による処理行の変化を挿入後にカウント変数に挿入数を加え代入して次の処理行特定しています
n = n + .Value
上から処理ですとどうしても処理が増えてしまいますね

メイン処理の行の挿入については他の方も回答されているので割愛しますが

Rows().Insert　や　EntireRow.Insertで調べてみて下さい
併せてOffsetプロパティとResizeプロパティも調べて理解されると
使い勝手が増え良いと思います

No.4 回答者： ssawatake 回答日時： 2023/12/04 17:08

No.3 改訂　もっと簡単に

Dim WS As Worksheet
Set WS = ActiveSheet
ENDR = WS.Range("A65536").End(xlUp).Row

For i = ENDR To 1 Step -1
　If IsNumeric(WS.Range("A" & i).Value) And WS.Range("A" & i).Value >= 1 Then
　　n = WS.Range("A" & i).Value
　　Rows(i + 1 & ":" & i + n).Insert
　End If
Next i

この回答へのお礼

問題なく実行できました。
素晴らしいです。

お礼日時：2023/12/05 08:30

No.3 回答者： ssawatake 回答日時： 2023/12/04 16:57

ここは半角スペースで字下げ出来ないので、全角スペースで字下げしてます。

Dim WS As Worksheet
Set WS = ActiveSheet
ENDR = WS.Range("A65536").End(xlUp).Row

For i = ENDR To 1 Step -1
　If IsNumeric(WS.Range("A" & i).Value) And WS.Range("A" & i).Value >= 1 Then
　　n = WS.Range("A" & i).Value
　　　For j = 1 To n
　　　　Rows(i + 1).Insert
　　　Next j
　End If
Next i

No.1 回答者： Qchan1962 回答日時： 2023/12/04 12:15

ざっくり　一例コードだけです

Sub test()
Dim i As Long
For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If IsNumeric(Cells(i, 1)) And Cells(i, 1) <> "" Then
Cells(i, 1).Offset(1).Resize(Cells(i, 1)).EntireRow.Insert
End If
Next
End Sub

この回答へのお礼

ありがとうございます。

検証したところ、「0」という表示があると、エラー400になりました。
「0」を消したら、問題なく実行できました。

実行する前に、「0」を消す・非表示などにすれば、大丈夫です。

大変助かりました。感謝の気持ちでいっぱいです。

お礼日時：2023/12/04 14:21