セル結合と列挿入

質問

マクロの記録を使い書いて見ましたが、１行置きに３行挿入し
、A2:A5 , B2:B5 ,C2:C5 ,D2,D5 言う感じでセル結合を5000行まで行い、最後にＤ、E列、列の挿入したいのですが、どのように書けば宜しいでしょうか？
すでに、データが入っています。

Sub Macro1()
Rows("3:5").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("7:9").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A2:A5").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("B2:B5").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("C2:C5").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("A6:A9").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("B6:B9").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Range("C6:C9").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Columns("D:E").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.ColumnWidth = 18.88
Range("A2:A5").Select
End Sub

回答No.3

tom04 · ベストアンサー

No.1・2です。

ご希望ウ通りの動きでないようで、ごめんなさい。
とりあえずマクロを二つにしてみました。

Sub 行挿入()
Dim i As Long
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
Rows(i + 1 & ":" & i + 3).Insert
Next i
End Sub

Sub セル結合()
Dim i, j As Long
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To 26
If Cells(i, j) <> "" Then
With Range(Cells(i, j), Cells(i + 3, j))
.Merge
.HorizontalAlignment = xlCenter
End With
End If
Next j
Next i
End Sub

今回はセル範囲の挿入ではなく、行挿入にしています。
※　今回も　画面更新は敢えてやっていません。

こんなんで良いのでしょうかね？m(_ _)m

お礼

はい、お手数お掛けしましたありがとうございました

回答No.2

tom04

No.1です！
たびたびごめんなさい。
質問内の
＞１行置きに３行挿入し・・・
の部分を見逃していました。

前回のコードは無視してください。

Sub test()
Dim i, j As Long
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
Range(Cells(i + 1, 1), Cells(i + 3, 4)).Insert (xlDown)
Next i
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
For j = 1 To 4
If Cells(i, j) <> "" Then
With Range(Cells(i, j), Cells(i + 3, j))
.Merge
.HorizontalAlignment = xlCenter
End With
End If
Next j
Next i
Range(Columns("D"), Columns("E")).Insert
End Sub

今回のコードはA～D列と決めつけてやっています。
各列毎に行挿入してしまうともっと時間がかかってしまうため
敢えて、4列まとめて行挿入しています。

それでも結構時間がかかってしまうと思いますので、
敢えて画面更新を表示するようにしています。
（Application Screenupdating=FALSE・TRUEをコードに入れていません）

画面更新をしないようにすると画面はずっと砂時計のままになります。
少しは画面が変化していた方がマクロが走っている感じがすると思いますので・・・

時間短縮できる方法があればごめんなさいね。m(_ _)m

補足

ご投稿いただきありがとございます、私の説明不足も重なりごめんなさい
データは、すでにA列：Ｚ列まで入ってる為、行挿入時は、行１の部分にはタイトルが入ってる為、行２の下に新しく３行挿入（A列：Ｚ列まで）、同じく行６下に新しく３行挿入（A列：Ｚ列まで）・・・・・と言った感じにしたいです、

ごめんなさい

回答No.1

tom04

こんばんは！
コードを詳しく見ていませんが・・・

A～D列の2行目以降を
4行ずつ「結合・中央揃え」としています。

Sub test()
Dim i, j As Long
Application.ScreenUpdating = False
For j = 1 To 4 '←A列～D列までとしています。
For i = 2 To 5000 Step 4
With Range(Cells(i, j), Cells(i + 3, j))
.Merge
.HorizontalAlignment = xlCenter
End With
Next i
Next j
Application.ScreenUpdating = True
Range(Columns("D"), Columns("E")).Insert
End Sub

※　若干時間がかかると思います。

こんな感じでよろしいのでしょうか？m(_ _)m

補足

こんばんは、早速試してみました、データの無いシートでは旨く動作しますが、データがすでに入ってるシートでは？？