指定記号のみ別シートにコピー

質問

sheet1（表-1）の入力文字「A,C,E」をsheet2へコピーする。
sheet2（表-3)のように[A,C,E」以外及びsheet1空白のセルはsheet2でも空白としたい。
その際、sheet2（表-2)に入力済みの記号「○、●、◎」はそのまま残したい。
下記のコードでは、sheet2に入力済みの記号「○、●、◎」が消えてしまいます。
どなたかコードがわかる方よろしくお願いします。

Sub シートコピー()
Dim r As Range
For Each r In Worksheets("Sheet1").Range("B1:D5")
If WorksheetFunction.CountIf(Range("A8:A10"), r.Value) Then

Sheets("sheet2").Range(r.Address).Value = r.Value
Else
Sheets("sheet2").Range(r.Address).Value = ""
End If
Next
End Sub

セルA11に"0"を入力して実行してもsheet1空白セルはsheet2でも空白となり困っています。

回答No.1

queuerev2 · ベストアンサー

今回の図はとても見やすいので滞りなく検討することができました。

Sub シートコピー()
Dim r As Range
For Each r In Worksheets("Sheet1").Range("B1:D5")
With Sheets("Sheet2")
If WorksheetFunction.CountIf(.Range("A8:A10"), r.Value) Then

.Range(r.Address).Value = r.Value
ElseIf WorksheetFunction.CountIf(.Range("C8:C10"), .Range(r.Address).Value) = 0 Then
.Range(r.Address).Value = ""
End If
End With
Next
End Sub

少し解説すると、
sheet1が入力文字の場合はsheet2に記入、
違う場合、sheet2が記号「○、●、◎」(sheet2のC8:C10でない場合は""を記入（セルを空白に）
としたところ、表-3と同一の結果が得られました。
ついでに、Range("A8:A10")のところも一応明示的にSheets("Sheet2")を指定し、その結果Sheets("Sheet2")が５個になってしまったのでWith Sheets("Sheet2")を使ってみました。

蛇足ですが、WorksheetFunction.CountIfのかわりにRange.Findを使うこともできます。
たとえば、
If WorksheetFunction.CountIf(.Range("A8:A10"), r.Value) Then
は
If Not .Range("A8:A10").Find(r.Value) Is Nothing Then
でもかまいません。

お礼

本当ににありがとうございます。思い通りにシートに入力できました。今後、質問添付図は見やすいよう心掛けます。