[[20210305161334]]　『１行のものをn（５）行にコピー』（より）　ページの最後に飛ぶ

『１行のものをn（５）行にコピー』（より）

よろしくおねがいします。

数百行のデータがあり、それぞれの行は違うデータです。
その行を５行分にしたいです。（4行分追加）

手作業ですと時間がかかるので。

1行目のデータは2,3,4,5行目に1行目と同じデータをで計5行コピー。
元々2行目にあったデータは6行目になっていると思うので、
7,8,9,10行目に6行目のデータで計5行。

元々
A
B
C
↓コピー後
A
A
A
A
A
B
B
B
B
B
C
C
C
C
C

といった感じで1行を＋4行下に追加して5行にしたいです。

説明が少しわかりにくいかもしれませんが、よろしくおねがいします。

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

１）連番列を作成
２）一番下に、４セット分コピペ
３）連番列で並び替え
４）連番列削除

（マナ） 2021/03/05(金) 16:30

 横から失礼します。

別セルでいいなら。

 =INDIRECT("Sheet1!A"&INT((ROW()-1)/5+1))
（OK） 2021/03/05(金) 16:36

VBA勉強中の為、練習としてチャレンジさせていただきました。
まず自分が思いついたもの

Sub test1()

    Dim i As Long
    For i = Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1
        Cells(i, 1).Copy
        Range(Cells(i, 1), Cells(i + 3, 1)).Insert Shift:=xlDown
    Next
End Sub

動作はしますが数が増えるとどんどん遅くなるので失敗作です。

そしてマナさんのヒントを元に試行錯誤して作成したもの

Sub test2()

    '変数宣言
    Dim i As Long
    Dim lastrow As Long
    Dim x As Long
    Dim ix As Long

    'B列に連番作成処理
    x = 1
    For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
        Cells(i, 2) = x
        x = x + 1
    Next

    '希望範囲をコピー処理
    lastrow = Cells(Rows.Count, "A").End(xlUp).Row
    Range(Cells(1, 1), Cells(lastrow, 2)).Copy

    '4回貼り付け処理
    x = 0
    Do While x < 4
    ix = Cells(Rows.Count, "A").End(xlUp).Row + 1
        Cells(ix, 1).PasteSpecial
        x = x + 1
    Loop

    'B列を小さい順に並び変えてB列クリア処理
    Range("A:B").Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess
    Columns("B").Clear
    Range("A1").Select
End Sub

数が増えても最初の案より遅くなりにくいです。
ですが拙い知識で作成したものなのでご自身で作成する際の参考程度に。
（くまさん） 2021/03/05(金) 18:48

 A1～A列最終行の値を一旦配列に読み込んで、別の配列に指定数回
 分繰り返したものを書き込んで、配列をセルに書き込んでみました。
 元のセルに上書きされますので、必要に応じて別のセルに書き込むように
 調整してみてください。

Sub test()

 Dim rng As Range
 Dim ary() As Variant
 Dim cnt As Long
 Dim itm As Variant
 Dim i As Integer
 Dim num As Integer
  Set rng = ActiveSheet.Range(ActiveSheet.Range("A1"), ActiveSheet.Range("A" & Rows.Count).End(xlUp))
  cnt = -1
  num = 5
  ReDim ary(0 To rng.Cells.Count * 5 - 1)
  For Each itm In rng.Value
   cnt = cnt + 1
   For i = 1 To num
    ary(cnt * num + i - 1) = itm
   Next i
  Next itm
  rng.Resize(1, 1).Resize((cnt + 1) * num).Value = WorksheetFunction.Transpose(ary)
  Erase ary
  Set rng = Nothing
End Sub
（OK） 2021/03/05(金) 19:46

 >ReDim ary(0 To rng.Cells.Count * 5 - 1)

 修正漏れです。↓に読み替えてください。

 ReDim ary(0 To rng.Cells.Count * num - 1)
（OK） 2021/03/05(金) 19:50

手順さえ、理解してしまえば
手作業でよいと思います

 Sub test()
    Dim r As Range

    Columns(1).Insert
    Set r = Cells(1).CurrentRegion
    r.Columns(1).Value = Evaluate("row(1:" & r.Rows.Count & ")")

    r.Copy r.Resize(r.Rows.Count * 5)

    Set r = r.CurrentRegion
    r.Sort r.Columns(1)

    Columns(1).Delete

 End Sub

（マナ） 2021/03/05(金) 21:25

コメント返信：

[ 一覧(最新更新順) ]

[[20210305161334]] 『１行のものをn（５）行にコピー』（より） ページの最後に飛ぶ

[[20210305161334]]　『１行のものをn（５）行にコピー』（より）　ページの最後に飛ぶ