行数が増えると、For〜Next で2行目までループしているのが無駄なので、
G列で"済"など何か入力されている行までをループするようにしてみました。
このような感じでいかがでしょうか。
Sub test1()
Dim i As Long
Dim lastRow As Long, s_Row As Long
Dim lastRow2 As Long
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
lastRow2 = Cells(Rows.Count, 7).End(xlUp).Row
For i = lastRow To lastRow2 Step -1
If Cells(i, 4).Value > 1 And Cells(i, 7).Value <> "済" Then
s_Row = Cells(i, 4).Value - 1
Range("A" & i + 1 & ":A" & i + s_Row).EntireRow.Insert
Range("G" & i).Value = "済"
Range("A" & i & ":G" & i).Copy Range("A" & i + 1 & ":G" & i + s_Row)
End If
Next i
End Sub
または、For i = lastRow To 2 Step -1 の部分を実行するたびに適切な値に書き換えるとかの対処が必要です。
Sub test1() Dim i As Long Dim lastRow As Long, s_Row As Long
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = lastRow To 2 Step -1 If Cells(i, 4).Value > 1 Then s_Row = Cells(i, 4).Value - 1 Range("A" & i + 1 & ":A" & i + s_Row).EntireRow.Insert Range("A" & i & ":F" & i).Copy Range("A" & i + 1 & ":F" & i + s_Row) End If Next i
End Sub -------- 複数回実行したもいいように、コードを実行して挿入&コピーをしたら G列にコピーしたら”済“と入力するように改変しました。 G列に"済"が入力されていないと、挿入&コピー対象となります。 これでどうでしょう。
Sub test1() Dim i As Long Dim lastRow As Long, s_Row As Long
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = lastRow To 2 Step -1 If Cells(i, 4).Value > 1 And Cells(i, 7).Value <> "済" Then s_Row = Cells(i, 4).Value - 1 Range("A" & i + 1 & ":A" & i + s_Row).EntireRow.Insert Range("G" & i).Value = "済" Range("A" & i & ":G" & i).Copy Range("A" & i + 1 & ":G" & i + s_Row) End If Next i
C列の商品数が1以上の時(4や2)行を挿入してコピーしたい
A B C D E F
注文番号 商品番号 商品 注文数量 名前 ふりがな
317104911 AH01-NT a 1 a a
375504911 AH04-NT b 1 b b
546104901 AH07-NT c 1 c c
951704891 AH02-NT d 4 d d
956404891 AH10-NT e 2 e e
イメージ
A B C D E F
注文番号 商品番号 商品 注文数量 名前 ふりがな
317104911 AH01-NT a 1 a a
375504911 AH04-NT b 1 b b
546104901 AH07-NT c 1 c c
951704891 AH02-NT d 4 d d
951704891 AH02-NT d 4 d d
951704891 AH02-NT d 4 d d
951704891 AH02-NT d 4 d d
956404891 AH10-NT e 2 e e
956404891 AH10-NT e 2 e e