EXCELで複数行を自動コピー＆挿入

質問

エクセルで、100行、AからZまで数字やテキストが入力されいるシートがあります。
この100行のデータの1行につき、その下に5行をコピー挿入したいのです。つまり、１行目のデータと2行目のデータの間に1行目データ5行分自動挿入させる。さらにこの時、1行目のAからZまでのセルで、特定のセル（たとえば、BとTのコラム）のみ、コピーをしない、という設定をしたいのです。
よろしくお願いいたします。

回答No.5

mar00 · ベストアンサー

ANo.4です。
Range("B" & GYOU1 & ":B" & GYOU3).ClearContents '(1)
Range("T" & GYOU1 & ":T" & GYOU3).ClearContents '(2)
の部分ですが
Range("B" & GYOU1 + 1 & ":B" & GYOU3).ClearContents '(1)
Range("T" & GYOU1 + 1 & ":T" & GYOU3).ClearContents '(2)
です。

回答No.4

mar00

データは1行目から始まっているものとします。
Sub Macro1()
GYOU1 = Cells(Rows.Count, 1).End(xlUp).Row
Range("AA1") = "1"
Range("AA1:AA" & GYOU1).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
Step:=1, Trend:=False

COUNTR = 0
Do Until COUNTR = 5
COUNTR = COUNTR + 1
GYOU2 = Cells(Rows.Count, 1).End(xlUp).Row + 1
Range("A1:AA" & GYOU1).Copy
Range("A" & GYOU2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Loop
GYOU3 = Cells(Rows.Count, 1).End(xlUp).Row

Range("B" & GYOU1 & ":B" & GYOU3).ClearContents 　　'(1)
Range("T" & GYOU1 & ":T" & GYOU3).ClearContents　　 '(2)

Range("A1").Select
Range("A1:AB48" & GYOU3).Sort Key1:=Range("AA1"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal
Columns("AA:AA").ClearContents
End Sub
(1)がB列、(2)がT列をコピーしないのではなく、コピー後クリアしています。
コピーしたくない列を適宜指定してください。

回答No.3

tom04

No.2です！
たびたびごめんなさい。
前回のコードで1行抜けていました。
Sheet2をアクティブにしないと貼り付けができないと思います。
↓のコードの訂正してください。

Sub test() 'この行から
Dim i, j As Long
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("sheet1") '←Sheet名は適宜変更してください。
Set ws2 = Worksheets("sheet2") '←こちらのSheet名も適宜変更
For j = 1 To 26
For i = 1 To 100
ws2.Cells((i - 1) * 6 + 1, j) = ws1.Cells(i, j)
Next i
Next j
For i = 1 To 600
For j = 1 To 26
If ws2.Cells(i, j) = "" Then
ws2.Cells(i, j) = ws2.Cells(i - 1, j)
End If
Next j
Next i
Dim str As String
On Error Resume Next
If MsgBox("行挿入しない列はありますか？", vbYesNo) = vbYes Then
処理1:
str = InputBox("挿入しない列番号をIMEをOFFにして、" & vbCrLf & "アルファベットで入力してください。")
ws2.Columns(str).Clear
ws1.Columns(str).Copy
ws2.Activate
ws2.Columns(str).Select
ActiveSheet.Paste
Else
Exit Sub
End If
If MsgBox("他にも行挿入しない列はありますか？", vbYesNo) = vbYes Then
GoTo 処理1
Else
Exit Sub
End If
Application.CutCopyMode = False
End Sub 'この行まで

何度も失礼しました。m(__)m

お礼

マクロの方法をお教えいただき、ありがとうございました。
コピー複製は問題なかったのですが、指定行のデータをコピーしないというのが、ちょっとうまくいきませんでした。確かにコピーはされていないのですが、sheet2にできたシートの頭にある複製された行の差最初の100行分にデータが残るようで、オリジナルの100行のデータを保存するのとは違っているようでした。でも、削除は手動でもできるので、なっとくです。ありがとうございました。

回答No.2

tom04

こんばんは！
VBAでの方法になってしまいますが・・・
一例です。

Sheet1で行挿入でなく、Sheet2の方に表示する方法にしてみました。

方法としては、とりあえずSheet2のすべての列にSheet1のデータを6行ずる表示させ、
INPUTBOXで行挿入しない列を選択（入力）　→　データをクリア　→　Sheet1の列をコピー
といった感じです。

画面左下にある操作したいSheet見出し上で右クリック　→　コードの表示　→　VBE画面が出ますので
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub test() 'この行から
Dim i, j As Long
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("sheet1") '←Sheet名は適宜変更してください。
Set ws2 = Worksheets("sheet2") '←こちらのSheet名も適宜変更
For j = 1 To 26
For i = 1 To 100
ws2.Cells((i - 1) * 6 + 1, j) = ws1.Cells(i, j)
Next i
Next j
For i = 1 To 600
For j = 1 To 26
If ws2.Cells(i, j) = "" Then
ws2.Cells(i, j) = ws2.Cells(i - 1, j)
End If
Next j
Next i
Dim str As String
On Error Resume Next
If MsgBox("行挿入しない列はありますか？", vbYesNo) = vbYes Then
処理1:
str = InputBox("挿入しない列番号をIMEをOFFにして、" & vbCrLf & "アルファベットで入力してください。")
ws2.Columns(str).Clear
ws1.Columns(str).Copy
ws2.Columns(str).Select
ActiveSheet.Paste
Else
Exit Sub
End If
If MsgBox("他にも行挿入しない列はありますか？", vbYesNo) = vbYes Then
GoTo 処理1
Else
Application.CutCopyMode = False
Exit Sub
End If
End Sub 'この行まで

参考になれば良いのですが・・・m(__)m

回答No.1

MackyNo1

以下のような手順で作業してください。

データのあるZ列の右の列のセル（1行目が項目名ならAA2セル）に１、その下のAA3セルに２と入力して、2つのセルを選択し、その右下をダブルクリックして１からデータ数（１００）までの連番をふります。

次に、A2セルを選択しCtrl+Shift+Endでデータ範囲を選択し、Ctrl+Cでコピーし。Ctrl+↓のショートカット操作でA列の一番下のセルを選択し、↓キーで追加したいセルを選択し、Ctrl+Vで貼り付けます。
そのまま、もう一度Ctrl+↓のショートカット操作でA列の一番下のセルを選択し、↓キーで追加したいセルを選択し、Ctrl+Vで貼り付けます。

この操作を5回繰り返したら、一番上の100行以外のセルの削除したいB列とT列のデータを削除してから、「データ」「並べ替え」でAA列を基準に昇順に並べ替えてください。

お礼

なるほどですね。マクロを使わない方法としては最適でした。ありがとうございます。