VBA 複数の行を挿入後、挿入以外を削除

質問

知恵をお借りください。

A10に5行分挿入、A13に2行分挿入、A14に1行分挿入、A16に2行分挿入
以下がコードです。

Dim n As Long
n = Worksheets("Sheet1").Range("A1").Value
With Worksheets("Sheet2")
.Range("A10").Resize(n).EntireRow.Insert
.Range("A10").Resize(n).EntireRow.Interior.Color = vbYellow
.Activate
End With

Dim k As Long
k = Worksheets("Sheet1").Range("A2").Value
With Worksheets("Sheet2")
.Range("A13").Resize(n).EntireRow.Insert
.Range("A13").Resize(n).EntireRow.Interior.Color = vbRed
.Activate
End With

Dim m As Long
m = Worksheets("Sheet1").Range("A5").Value
With Worksheets("Sheet2")
.Range("A14").Resize(n).EntireRow.Insert
.Range("A14").Resize(n).EntireRow.Interior.Color = vbGreen
.Activate
End With

Dim ka As Long
ka = Worksheets("Sheet1").Range("A10").Value
With Worksheets("Sheet2")
.Range("A16").Resize(n).EntireRow.Insert
.Range("A16").Resize(n).EntireRow.Interior.Color = vbBlue
.Activate
End With

マクロ実行後、行の並び方がバラバラになっています。
↓イメージ図
https://mega.nz/#!yUwXHTLK!TSZvMJ1CaiTi-OoX-1j9IeNleuXesrzU5O7o2vG-svI
理想図に整えるにはどうすれば良いのでしょうか？

また、マクロで行を挿入したら、不要な行を削除するコードも教えてくださればありがたいです。
↓イメージ図
https://mega.nz/#!fMRDAKAJ!GHMpiagpn-O_0aaMhrHOozFd8WHHkSQzOS-fSCInw-g

宜しくお願いします。

この投稿のマルチメディアは削除されているためご覧いただけません。

回答No.6

watabe007 · ベストアンサー

Sub 行挿入()
Dim c As Range, n As Long
Application.ScreenUpdating = False
Worksheets("Sheet2").Activate
For Each c In Worksheets("Sheet1").Range("A2:A5")
n = c.Offset(, 1).Value
Range(c.Value).Resize(n).EntireRow.Insert
Range(c.Value).Resize(n).EntireRow.Interior.Color = c.Offset(, 2).Interior.Color
Next
Application.ScreenUpdating = True
End Sub

Sub 行削除()
Dim i As Long, n As Long, add As String
Application.ScreenUpdating = False
Worksheets("Sheet2").Activate

With Worksheets("Sheet1").Range("A2:A5")
For i = .Rows.Count To 1 Step -1
n = .Cells(i, 2).Value
add = .Cells(i, 1).Value
Range(add).Resize(n).EntireRow.Delete
Next
End With
Application.ScreenUpdating = True
End Sub

補足

たびたびですみません。
上記のように単体で分けて、
「行挿入」のマクロを実行しても
「Rangeメソッドは失敗しました'_Global'オブジェクト」とエラーメッセージが出ます。

回答No.8

watabe007

>挿入した行以外を削除したかったのですが。
今日の挿入は理解されましたね、
では、次から行の削除にかかりましょう
どの行を削除しますか、ルールなどありましたら詳しくお願いします。

お礼

ありがとうございます。
すみません、説明が難しくなりましたので、一旦終了させてください。
改めて再度質問させてください。
宜しくお願いします。

回答No.7

watabe007

>「行挿入」のマクロを実行しても
>「Rangeメソッドは失敗しました'_Global'オブジェクト」とエラーメッセージ
シート1にイメージ図の様に書かれていますか

補足

あ、そういうことでしたか。
同様にやってみました。
行挿入は出来ましたが、行削除は実行したのですが、挿入した行を削除したため、元に戻っただけでした。
挿入した行以外を削除したかったのですが。

回答No.5

watabe007

>削除の方は「Rangeメソッドは失敗しました'_Global'オブジェクト」
今回に対応する削除コードは提示していませんが

補足

下記のコードは何でしょうか？
行挿入後の行の削除だと思いました。
単体で実行しても
「Rangeメソッドは失敗しました'_Global'オブジェクト」となります。

Sub Test()
　　Dim c As Range, n As Long, LR As Long
　　Application.ScreenUpdating = False
　　Worksheets("Sheet2").Activate
　　For Each c In Worksheets("Sheet1").Range("A2:A5")
　　　　n = c.Offset(, 1).Value
　　　　Range(c.Value).Resize(n).EntireRow.Insert
　　　　Range(c.Value).Resize(n).EntireRow.Interior.Color = c.Offset(, 2).Interior.Color
　　Next
　　Application.ScreenUpdating = True
End Sub

回答No.4

watabe007

>以下のコードを併用しましたが、「マクロを実行できません
提示したコードは、貴方が「値が変わるたびにマクロも修正するとなると・・・」
に対応すべくSheet1をUPしたイメージ図のようにする事で毎回コードを変更せずSheet1の値を変えることで対応できるのではとの提案です。
「以下のコードを併用しましたが」ではなく単体で実行してください。

補足

単体で実行しましたところ、行挿入はうまく出来ましたが、削除の方は「Rangeメソッドは失敗しました'_Global'オブジェクト」とエラーメッセージが出ます。

回答No.3

watabe007

>値が変わるたびにマクロも修正するとなると、
Sub Test()
　　Dim c As Range, n As Long, LR As Long
　　Application.ScreenUpdating = False
　　Worksheets("Sheet2").Activate
　　For Each c In Worksheets("Sheet1").Range("A2:A5")
　　　　n = c.Offset(, 1).Value
　　　　Range(c.Value).Resize(n).EntireRow.Insert
　　　　Range(c.Value).Resize(n).EntireRow.Interior.Color = c.Offset(, 2).Interior.Color
　　Next
　　Application.ScreenUpdating = True
End Sub

補足

ありがとうございます。
以下のコードを併用しましたが、「マクロを実行できません。マクロが使用できないか、またはすべてのマクロが無効になっている可能性があります」とエラーメッセージが出ます。
どこが間違っておりますか？
宜しくお願いします。

Sub 行挿入()

Dim ka As Long
ka = Worksheets("Sheet1").Range("A4").Value
With Worksheets("Sheet2")
.Range("A16").Resize(ka).EntireRow.Insert
.Range("A16").Resize(ka).EntireRow.Interior.Color = vbBlue
.Activate
End With

Dim m As Long
m = Worksheets("Sheet1").Range("A3").Value
With Worksheets("Sheet2")
.Range("A14").Resize(m).EntireRow.Insert
.Range("A14").Resize(m).EntireRow.Interior.Color = vbGreen
.Activate
End With

Dim k As Long
k = Worksheets("Sheet1").Range("A2").Value
With Worksheets("Sheet2")
.Range("A13").Resize(k).EntireRow.Insert
.Range("A13").Resize(k).EntireRow.Interior.Color = vbRed
.Activate
End With

Dim q As Long
q = Worksheets("Sheet1").Range("A1").Value
With Worksheets("Sheet2")
.Range("A10").Resize(q).EntireRow.Insert
.Range("A10").Resize(q).EntireRow.Interior.Color = vbYellow
.Activate
End With

    Dim c As Range, n As Long, LR As Long
    Application.ScreenUpdating = False
    Worksheets("Sheet2").Activate
    For Each c In Worksheets("Sheet1").Range("A2:A5")
        n = c.Offset(, 1).Value
        Range(c.Value).Resize(n).EntireRow.Insert
        Range(c.Value).Resize(n).EntireRow.Interior.Color = c.Offset(, 2).Interior.Color
    Next
    Application.ScreenUpdating = True

End Sub

回答No.2

watabe007

>A10に2行分挿入、A13に10行分挿入、A14に20行分挿入、A16に8行分挿入の
挿入は下から
Range("A16").Resize(8).EntireRow.Insert
Range("A14").Resize(20).EntireRow.Insert
Range("A13").Resize(10).EntireRow.Insert
Range("A10").Resize(2).EntireRow.Insert
この場合の削除は上から
Range("A10").Resize(2).EntireRow.Delete
Range("A13").Resize(10).EntireRow.Delete
Range("A14").Resize(20).EntireRow.Delete
Range("A16").Resize(8).EntireRow.Delete
デバッグのステップインを実行して一行一行の動きを観察すると良いですよ

お礼

値が変わるたびにマクロも修正するとなると、マクロより手動でやったほうが早いですね。

回答No.1

watabe007

行の挿入は下から行うのが基本です。
Sub 色塗り()
　　Dim n As Long
　　Worksheets("Sheet2").Activate
　　n = Worksheets("Sheet1").Range("A10").Value
　　Range("A17").Resize(n).EntireRow.Insert
　　Range("A17").Resize(n).EntireRow.Interior.Color = vbBlue

　　n = Worksheets("Sheet1").Range("A5").Value
　　Range("A15").Resize(n).EntireRow.Insert
　　Range("A15").Resize(n).EntireRow.Interior.Color = vbGreen

　　n = Worksheets("Sheet1").Range("A2").Value
　　Range("A14").Resize(n).EntireRow.Insert
　　Range("A14").Resize(n).EntireRow.Interior.Color = vbRed

　　n = Worksheets("Sheet1").Range("A1").Value
　　Range("A11").Resize(n).EntireRow.Insert
　　Range("A11").Resize(n).EntireRow.Interior.Color = vbYellow
End Sub
行の削除も下から
Sub 行削除()
　　Dim LR As Long
　　Worksheets("Sheet2").Activate
　　LR = Cells(Rows.Count, "A").Row
　　If LR < 27 Then LR = 27
　　Range("A27:A" & LR).EntireRow.Delete
　　Range("A23").EntireRow.Delete
　　Range("A16:A17").EntireRow.Delete
　　Range("A1:A9").EntireRow.Delete
End Sub

補足

ありがとうございます。
下から挿入を行うのでしたか。盲点でした。
うまくいきました。

行削除の方ですが。
テストとして
A10に2行分挿入、A13に10行分挿入、A14に20行分挿入、A16に8行分挿入のマクロを実行しましたが、行削除はうまくいきませんでした。

説明不足ですみません。挿入する数値はバラバラです。
宜しくお願いします。