エクセルのマクロでの質問です

質問

エクセルのマクロでの質問です。
やりたいことは、
明細シートから、「1.3.5」の条件に合うものを実績シートの最終行にコピーして追加していきたいんです。
これだと、実績シートの最終行にはコピーされるんですが
最終行に全部が上書きコピーされる状態になってしまってます。
どう直せば、追加される形になりますか？

Sub コピー()
'1,3,5のものを実績にコピーする

i = 5
J = Sheets("実績").Cells(Rows.Count, 4).End(xlUp).Row + 1

Sheets("明細").Select

Do While Cells(i, 8).Value <> ""
If Cells(i, 3).Value = 1 Or Cells(i, 3) = 3 Or Cells(i, 3) = 5 Then
Range("D5", "H5").Copy
Sheets("実績").Select
Range("C" & J).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

End If
i = i + 1
Loop

End Sub

まったくのマクロ初心者です。
分かりやすく教えていただけると、助かります。

また、参考になりそうなサイトなどがあったら、教えてください。

回答No.3

keithin · ベストアンサー

貼り付け先になる「Ｊ」行を，貼り付ける直前に「毎回調べます」。他にもいくつか間違っています。

Sub コピー()
'1,3,5のものを実績にコピーする

　i = 5

　Sheets("明細").Select

　Do While Cells(i, 8).Value <> ""
　　If Cells(i, 3).Value = 1 Or Cells(i, 3) = 3 Or Cells(i, 3) = 5 Then
　　Range(cells(i, "D"), cells(i, "H")).Copy　　’間違い修正

　　Sheets("実績").Select
　　J = Cells(Rows.Count, 4).End(xlUp).Row + 1　　’ここで調べる。
　　Range("C" & J).PasteSpecial Paste:=xlPasteValues
　　Application.CutCopyMode = False
　　Sheets("明細").Select　　　　　　　’追加

　　End If
　i = i + 1
　Loop
End Sub

＃参考
あんまりちょっとなんで，丸ごと書き直します。
ご質問で掲示されたマクロから，Ｃ列からＨ列までをＣ列からＨ列までにコピーするように変えています。

sub macro1()
　dim h as range
　worksheets("明細").select

　for each h in range("C5:C" & range("H65536").end(xlup).row)
　　if h.value = 1 or h.value = 3 or h.value = 5 then
　　　h.resize(1, 6).copy destination:=workhseets("実績").range("C65536").end(xlup).offset(1)
　　end if
　next
end sub

お礼

ありがとうございました。
書き直していただいたものが、早いしスッキリしてます。

こんなに短いものでも、いろいろな書き方があるんですね。
勉強になります。

回答No.2

mu2011

一例です。

Sub コピー()
'1,3,5のものを実績にコピーする
Set 明細 = Sheets("明細")
Set 実績 = Sheets("実績")
i = 5
j = 実績.Cells(Rows.Count, 4).End(xlUp).Row
明細.Range("D5", "H5").Copy
Do While 明細.Cells(i, 8).Value <> ""
Select Case 明細.Cells(i, 3).Value
Case 1, 3, 5
j = j + 1
実績.Range("C" & j).PasteSpecial Paste:=xlPasteValues
End Select
i = i + 1
Loop
Application.CutCopyMode = False
End Sub

お礼

ありがとうございました。
参考にさせていただきます。

回答No.1

kybo

★印が変更した場所です。

Sub コピー()
'1,3,5のものを実績にコピーする
i = 5
J = Sheets("実績").Cells(Rows.Count, 4).End(xlUp).Row　’★
Sheets("明細").Select
Do While Cells(i, 8).Value <> ""
If Cells(i, 3).Value = 1 Or Cells(i, 3) = 3 Or Cells(i, 3) = 5 Then
Range("D5", "H5").Copy
Sheets("実績").Select
Range("C" & J).Offset(1).PasteSpecial Paste:=xlPasteValues　’★
Application.CutCopyMode = False
End If
i = i + 1
Loop
End Sub

お礼

早々の回答ありがとうございます。
参考にさせていただきます。