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

質問

先回はごちゃごちゃしていました。
https://okwave.jp/qa/q9540698.html

今回はwatabe007様より、ヒントを得て、やり易くするように流れを変えました。

●「挿入」シートにナンバーの数字が1～（100以上）と順次に並んでいます。

「挿入」シート
　1
　2
　3
　4
　5
　6
　7
　8
　9
　10
　・
　・
　・
　100くらい

●「入力」シートにナンバーの数字、行挿入の数、色分けの三つあります。

「入力」シート
ナンバー　挿入する行の数　色　
　4　　　　　　5　　　　　赤　
　6　　　　　　3　　　　　黄色
　8　　　　　　4　　　　　緑
　9　　　　　　1　　　　　青

上記を入力し、マクロ実行すると「挿入」シートのナンバー4に5行挿入、6に3行挿入、8に4行挿入、9に1行挿入

「挿入」シート
　1
　2
　3
　4
（行挿入）
（行挿入）
（行挿入）
（行挿入）
（行挿入）
　5
　6
（行挿入）
（行挿入）
（行挿入）
　7
　8
（行挿入）
（行挿入）
（行挿入）
（行挿入）
　9
（行挿入）
　10
　・
　・
　100くらい

マクロ実行で、シート名「入力」に記載していたナンバーと挿入した行以外を削除

「挿入」シート
　4
（行挿入）
（行挿入）
（行挿入）
（行挿入）
（行挿入）
　6
（行挿入）
（行挿入）
（行挿入）
　8
（行挿入）
（行挿入）
（行挿入）
（行挿入）
　9
（行挿入）

といった流れが望ましいです。
宜しくお願いします。

回答No.7

watabe007 · ベストアンサー

>入力シートに4の数字があったら挿入シートのA列に順次に並べている
>4の数字と一致したら、行を挿入するといった流れです
Sub Test4()
　　Dim NewSheet As Worksheet, V As Variant
　　Dim i As Long, 行 As Long, myR As Variant
　　Application.ScreenUpdating = False
　　With Worksheets("入力")
　　　　V = .Range("A2:B" & .Cells(1, 1).End(xlDown).Row)
　　End With
　　Set NewSheet = Worksheets.Add(Before:=Worksheets("挿入"))
　　With Worksheets("挿入")
　　　　.Rows(1).Copy
　　　　NewSheet.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
　　　　NewSheet.Cells(1, 1).PasteSpecial Paste:=xlPasteAll
　　　　NewSheet.Cells(1, 1).Select
　　　　行 = 2
　　　　For i = 1 To UBound(V)
　　　　　　myR = Application.Match(V(i, 1), .Columns(1), 0)
　　　　　　If IsError(myR) Then
　　　　　　　　MsgBox V(i, 1) & " が見つかりません。"
　　　　　　　　Exit Sub
　　　　　　End If
　　　　　　.Rows(myR).Copy NewSheet.Cells(行, 1)
　　　　　　行 = 行 + V(i, 2) + 1
　　　　Next
　　End With
　　Application.DisplayAlerts = False
　　Worksheets("挿入").Delete
　　Application.DisplayAlerts = True
　　NewSheet.Name = "挿入"
　　Application.CutCopyMode = False
　　Application.ScreenUpdating = False
　　MsgBox "処理終了"
End Sub

お礼

おかげ様でうまくできました。
最後まで付き合ってくださりありがとうございました。

回答No.6

watabe007

>一行分ずれているようです。
「入力」シート
ナンバー　挿入する行の数　色　
　4　　　　　　5　　　　　赤　
　6　　　　　　3　　　　　黄色
　8　　　　　　4　　　　　緑
　9　　　　　　1　　　　　青
ナンバーに書かれている4は、4行目に挿入する事でしょ
その後、1行目に項目行を増やしたのだから
1行増やして5と書かなければならないのでは
5　　5
7　　3
9　　4
10　　1

補足

ややこしくてすみません。
4、6、8、9とかは行目ではなく、数字です。
入力シートに4の数字があったら挿入シートのA列に順次に並べている4の数字と一致したら、行を挿入するといった流れです。

回答No.5

watabe007

番外編
Sub 別案()
　　Dim NewSheet As Worksheet, V As Variant
　　Dim i As Long, 行 As Long
　　Application.ScreenUpdating = False
　　With Worksheets("入力")
　　　　V = .Range("A2:B" & .Cells(1, 1).End(xlDown).Row)
　　End With
　　Set NewSheet = Worksheets.Add(Before:=Worksheets("挿入"))
　　With Worksheets("挿入")
　　　　.Rows(1).Copy
　　　　NewSheet.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
　　　　NewSheet.Cells(1, 1).PasteSpecial Paste:=xlPasteAll
　　　　NewSheet.Cells(1, 1).Select
　　　　行 = 2
　　　　For i = 1 To UBound(V)
　　　　　　.Rows(V(i, 1)).Copy NewSheet.Cells(行, 1)
　　　　　　行 = 行 + V(i, 2) + 1
　　　　Next
　　End With
　　Application.DisplayAlerts = False
　　Worksheets("挿入").Delete
　　Application.DisplayAlerts = True
　　NewSheet.Name = "挿入"
　　Application.CutCopyMode = False
　　Application.ScreenUpdating = False
　　MsgBox "処理終了"
End Sub

回答No.4

watabe007

Sub Test3()
　　Dim ws1 As Worksheet, ws2 As Worksheet
　　Dim myR As Long, n As Long, n2 As Long
　　Dim i As Long, j As Long
　　Dim myCol As Long, flg As Boolean
　　Dim LR As Long, ER As Long, SR As Long
　　Application.ScreenUpdating = False
　　Worksheets("挿入").Activate
　　Set ws1 = Worksheets("入力")
　　Set ws2 = Worksheets("挿入")
　　 '行挿入処理
　　For i = ws1.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
　　　　j = j + 1
　　　　myR = ws1.Cells(i, 1).Value + 1
　　　　n = ws1.Cells(i, 2).Value
　　　　ws2.Rows(myR).Resize(n).Insert
　　　　ws2.Cells(myR, 1).Resize(n).Interior.Color = vbRed
　　　　ER = ER + n
　　　　If j = 1 Then ER = ER + ws1.Cells(i, 1).Value
　　Next
　　'行削除処理
　　SR = ws1.Range("A2").Value
　　LR = ws2.Cells(Rows.Count, "A").End(xlUp).Row
　　If LR < ER + 1 Then LR = ER + 1
　　ws2.Range(ER + 1 & ":" & LR).Delete
　　ws2.Range(2 & ":" & SR - 1).Delete
　　For i = ER To 2 Step -1
　　　　If ws2.Cells(i, 1).Interior.ColorIndex = xlNone And flg = True Then
　　　　　　ws2.Rows(i).Delete
　　　　ElseIf ws2.Cells(i, 1).Interior.ColorIndex = xlNone Then
　　　　　　flg = True
　　　　Else
　　　　　　ws2.Cells(i, 1).Interior.ColorIndex = xlNone
　　　　　　flg = False
　　　　End If
　　Next
　　Application.ScreenUpdating = True
　　MsgBox "処理終了"
End Sub

補足

ありがとうございます。
たびたびですみません。

ナンバー　挿入する行の数
　4　　　　　　5　　　　
　6　　　　　　3　　　　　
　8　　　　　　4　　　　　
　9　　　　　　1　　　　　
上記でマクロ実行しましたところ、以下が結果です。

ナンバー　挿入した行の数
　3　　　　　　5　　　　
　5　　　　　　3　　　　　
　7　　　　　　4　　　　　
　8　　　　　　1

一行分ずれているようです。

回答No.3

watabe007

>●挿入シートのセル1行目は名称をつけておき、マクロ実行はセル2行目から.
>にしたいのですが、その場合はコードのどこを変更したら良いでしょうか？
これは、全作業完了後に1行目を挿入すれば良いでしょう

●セルのカラーを省いたい場合はコードのどこを削除したら良いでしょうか？
カラーを省いたい場合とは挿入行に着色しないのですか？

補足

コメントありがとうございます。
挿入シートは最初からA1セルに名称があります。
A2から1，2，3…と順次に並べていますので、A2からマクロ実行できると思いました。A1から実行なので、名称が消えてしまっています。

色は見分け確認のためでつけてもらいました。実際は不要になりますので、
myCol = ws1.Cells(i, 3).Interior.Color
ws2.Rows(myR).Resize(n).Interior.Color = myCol
をどちらかを削除したり、片方を削除しても真っ黒になったり、真っ白になったり、削除の行がバラバラだったりとしています。
こちらの力では解決できませんでした。

回答No.2

watabe007

Sub Test()
　　Dim ws1 As Worksheet, ws2 As Worksheet
　　Dim myR As Long, n As Long, n2 As Long
　　Dim i As Long, j As Long
　　Dim myCol As Long, flg As Boolean
　　Dim LR As Long, ER As Long, SR As Long
　　Application.ScreenUpdating = False
　　Worksheets("挿入").Activate
　　Set ws1 = Worksheets("入力")
　　Set ws2 = Worksheets("挿入")
　　'行挿入処理
　　For i = ws1.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
　　　　 j = j + 1
　　　　myR = ws1.Cells(i, 1).Value + 1
　　　　n = ws1.Cells(i, 2).Value
　　　　myCol = ws1.Cells(i, 3).Interior.Color
　　　　ws2.Rows(myR).Resize(n).Insert
　　　　ws2.Rows(myR).Resize(n).Interior.Color = myCol
　　　　ER = ER + n
　　　　If j = 1 Then ER = ER + ws1.Cells(i, 1).Value
　　Next
　　'行削除処理
　　SR = ws1.Range("A2").Value
　　LR = ws2.Cells(Rows.Count, "A").End(xlUp).Row
　　If LR < ER + 1 Then LR = ER + 1
　　ws2.Range(ER + 1 & ":" & LR).Delete
　　ws2.Range(1 & ":" & SR - 1).Delete
　　For i = ER - SR + 1 To 2 Step -1
　　　　If ws2.Cells(i, 1).Interior.ColorIndex = xlNone And flg = True Then
　　　　　　ws2.Rows(i).Delete
　　　　ElseIf ws2.Cells(i, 1).Interior.ColorIndex = xlNone Then
　　　　　　flg = True
　　　　Else
　　　　　　flg = False
　　　　End If
　　Next
　　Application.ScreenUpdating = True
End Sub

補足

毎回ありがとうございます。
お陰様で動作できました。
質問ですが。
●挿入シートのセル1行目は名称をつけておき、マクロ実行はセル2行目からにしたいのですが、その場合はコードのどこを変更したら良いでしょうか？

●セルのカラーを省いたい場合はコードのどこを削除したら良いでしょうか？

宜しくお願いします。

回答No.1

watabe007

さて、今回はどうでしょう
Sub Test()
　　Dim ws1 As Worksheet, ws2 As Worksheet
　　Dim myR As Long, n As Long, myCol As Long
　　Dim j As Long, i As Long, n2 As Long
　　Application.ScreenUpdating = False
　　Worksheets("挿入").Activate
　　Set ws1 = Worksheets("入力")
　　Set ws2 = Worksheets("挿入")
　　 '行挿入処理
　　For i = ws1.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
　　　　j = j + 1
　　　　myR = ws1.Cells(i, 1).Value + 1
　　　　n = ws1.Cells(i, 2).Value
　　　　myCol = ws1.Cells(i, 3).Interior.Color
　　　　ws2.Rows(myR).Resize(n).Insert
　　　　ws2.Rows(myR).Resize(n).Interior.Color = myCol
　　　　If j = 1 Then
　　　　　　ws2.Cells(myR, 1).NoteText "END"
　　　　　　n2 = ws1.Cells(i, 2).Value
　　　　End If
　　Next
　　'行削除処理
　　Dim LR As Long, ER As Long, SR As Long
　　SR = ws1.Range("A2").Value
　　LR = ws2.Cells(Rows.Count, "A").End(xlUp).Row
　　For i = LR To 2 Step -1
　　　　If Cells(i, 1).NoteText = "END" Then
　　　　　　ER = i
　　　　　　Exit For
　　　　End If
　　Next
　　ws2.Cells(ER, 1).ClearComments
　　ws2.Range(ER + n2 & ":" & LR).Delete
　　ws2.Range(1 & ":" & SR).Delete
　　Application.ScreenUpdating = True
End Sub