指定回数分行をコピーして下に挿入する

投稿者 : 迷える羊     投稿日時 : 2024/07/24(Wed) 16:01:37     OS : Windows 10     EXCEL : Office 365

---

いつもお世話になっております。

シートに横並びに同じカテゴリの項目が入っており、
E列でそのカテゴリが何個あるのか数えています。
そしてその個数分縦に並べ直したい、というものです。
ただ、まだ縦に並べる前の段階、
コピーして挿入という箇所すら出来てません、

　　　　E列　F列　　　G列　　　H列
1行目　 3　　いちご　 みかん　 メロン
2行目　 2　　バナナ　 すいか
3行目　 0
4行目　 1　　もも
↓
　　　　E列　F列　　　G列　　　H列
1行目　 3　　いちご
2行目　 3　　みかん
3行目　 3　　メロン
4行目　 2　　バナナ
5行目　 2　　すいか
6行目　 0
7行目　 1　　もも

－－
Dim 数 As Long, i As Long
　　
最終行 = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

On Error Resume Next
For 変数● = 最終行 To 1 Step -1
数 = Worksheets("Sheet1").Range(変数●, 5)
　For i = 0 To 数 - 1
　　Worksheets("Sheet1").Rows(変数●).Copy
　　Worksheets("Sheet1").Rows(変数● + 1).Insert
　Next i
Next 変数●
On Error GoTo 0
－－
どのようにしたら動きますでしょうか？

投稿者 : さんこう     投稿日時 : 2024/07/24(Wed) 16:37:15

---

＞どのようにしたら動きますでしょうか？

これ↓があると、問題点を見逃してしまいます。

On Error Resume Next

投稿者 : 迷える羊     投稿日時 : 2024/07/24(Wed) 17:23:18

---

■[返信 1] さんこうさん（2024-07-24 16:37:15）の記事
＞ ＞どのようにしたら動きますでしょうか？
＞
＞ これ↓があると、問題点を見逃してしまいます。
＞
＞ On Error Resume Next

ご指摘の「On Error Resume Next」を削除したところ、
数 = Worksheets("Sheet1").Range(変数●, 5)
が黄色になってしまいました。
ですが、これがどう問題なのかがわからないです、すみません。

投稿者 : さんこう     投稿日時 : 2024/07/24(Wed) 17:28:02

---

＞ですが、これがどう問題なのかがわからないです

エラーメッセージも出ているでしょうから、よく見た方がよろしいかと思います。


参考になれば。

＜VBA Range＞
https://www.google.com/search?q=VBA+Range

投稿者 : てらてら     投稿日時 : 2024/07/25(Thu) 06:10:13

---

こんにちは。

なかなか気付けないようなので。

Range(変数●, 5) はダメで　Range("E" & 変数●)　とします。
Cellsを使うべきでしょう。

On Error Resume Next　は不要です。
こういう場面で使うべきではありません。


その他、行をシフトして値を移していくのは結構面倒かも。
やり方はいくつかあるでしょう。
以下は一例です。ステップ実行すれば何をしているかわかると思います。

Sub macro()
    Dim num As Long, i As Long
    Dim row As Long, 最終行 As Long
    
    With Worksheets("Sheet1")
    最終行 = .Cells(Rows.Count, 5).End(xlUp).row
    
    For row = 最終行 To 1 Step -1
        num = .Cells(row, 5)
        For i = num - 1 To 1 Step -1
            .Rows(row + 1).Insert
            .Range("A" & row & ":E" & row).Copy .Range("A" & row + 1)
            .Cells(row + 1, 6) = .Cells(row, i + 6)
            .Cells(row + 1, 5) = .Cells(row, 5)
            .Cells(row, i + 6).ClearContents
        Next i
    Next row
    
    End With
    
End Sub