マクロで全てのシートで条件を満たすシートに行を挿入するにはどうしたらいいですか

質問

マクロ初心者です。自分でも作ってみたのですが、なかなか思うようにいかず困っています。
book内のシート3つ目から最後のシートで、条件に一致するシートの特定位置に行を挿入するということがしたいのですが。
条件とは、1列目の最後の行に「合計」と記入されていれば、行を4行挿入し、上の書式をコピーするというものです。
下記に記しているマクロは、シートを指定した場合には動くのですが、これにシートをnとして、FOR...Nextを付け加えてシートを順番に参照させようとしても、うまくいきません。

Sub 行挿入sample3()
With Sheets("10007")
For i = 7 To .Cells(Rows.Count, 1).End(xlUp).Row
If .Cells(i + 1, 1) = "" Then
Exit For
ElseIf .Cells(i + 1, 1) = "合計" Then
Range(Cells(i + 1, 1), Cells(i + 4, 1)).Select
Selection.EntireRow.Insert
Range(Cells(i, 1), Cells(i, 3)).Select
Selection.Copy
Range(Cells(i + 1, 1), Cells(i + 4, 3)).PasteSpecial xlPasteFormats
End If
Next i
End With
End Sub

知識をお持ちの方、教えていただけるととても助かります。よろしくお願いします。

回答No.3

n-jun · ベストアンサー

n-junです。

If文を

　If　r.Row　>　1　Then
　　　　If　r.Value　=　"合計"　And　r.Offset(-1).Value　<>　""　Then
　　　　　　　r.Resize(4).EntireRow.Insert　Shift:=xlDown
　　　　　　　r.Offset(-5).Resize(,　3).Copy
　　　　　　　r.Offset(-4).Resize(4,　3).PasteSpecial　xlPasteFormats
　　　　　　　Application.CutCopyMode　=　False
　　　　End　If
　End　If

としてみて下さい。

お礼

本当にありがとうございます。うまく動き、とても助かりました。
毎回丁寧にご回答頂いて、ありがとうございました。

回答No.2

n-jun

n-junです。

If文内を

If r.Value = "合計" Then
　　　r.Resize(4).EntireRow.Insert Shift:=xlDown
　　　r.Offset(-5).Resize(, 3).Copy
　　　r.Offset(-4).Resize(4, 3).PasteSpecial xlPasteFormats
　　　Application.CutCopyMode = False
End If

として下さい。

補足

ご丁寧ご回答いただき本当にありがとうございます。
大変申し訳内のですが、もう一つお伺いしたいことがありまして・・。
「合計」が記入されているセルの上のセルが空白である場合、行挿入しないというようにするにはどうしたらよいでしょうか。
何度もすみません。

回答No.1

n-jun

Sub　try()
　Dim　r　As　Range
　Dim　i　As　Integer

　For　i　=　3　To　Worksheets.Count
　　　　　With　Worksheets(i)
　　　　　　　　　　Set　r　=　.Cells(Rows.Count,　1).End(xlUp)
　　　　　　　　　　If　r.Value　=　"合計"　Then
　　　　　　　　　　　　　r.Resize(4).EntireRow.Insert　Shift:=xlDown
　　　　　　　　　　　　　r.Offset(-5).Resize(,　3).Copy　r.Offset(-4).Resize(4,　3)
　　　　　　　　　　End　If
　　　　　End　With
　Next
　Set　r　=　Nothing
End　Sub

みたいな事ですか？
⇒ブックをコピーしてから試して下さい。

補足

ありがとうございます。
確かにこんなかんじなのですが、書式だけをコピーしたいのですが。
すみません・・・。