指定文字のみセルコピーする方法

質問

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

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

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

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

回答No.3

queuerev2 · ベストアンサー

そうですか。うまくいきませんか。
もっと検討したいところですが、画像のシートが小さすぎて見えないので困っています。
補足にて詳しく説明いただけないでしょうか。
あるいはいっそのことこの質問を締め切ってもっと見やすい画像を用意して再質問していただいても結構です。
よろしくお願いします。

お礼

ありがとうございます。おっしゃる通り改めて質問しましたのでよろしくお願いします。

回答No.2

queuerev2

質問者様の画像を見直して考えてみたのですが、おそらくsheet2のA14:A18にA,C,F,Hが入っていて、それをWorksheetFunction.CountIf関数を使って判別しているのですね。
さらによく見ると、sheet2にボタンがあるので、それをクリックすることでこのMacro9が起動し、つまり起動時にアクティブになっているのはsheet2なのですね。
画像が小さく見づらかったのでよく見なかったために、間違えてsheet1のA14:A18であると思ってしまい、不要な修正を加えてしまいました。
申し訳ありません。

修正するところですが、
If WorksheetFunction.CountIf(Worksheets("Sheet1").Range("A14:A18"), r.Value) Then
'Sheet1以外がアクティブでも正常に動作するようにシートの指定を追加
を元の
If WorksheetFunction.CountIf(Range("A14:A18"), r.Value) Then
に戻してください。
（あるいは、この部分のSheet1をSheet2に変更してください。

おそらくこれでうまくいくと思います。
うまくいかない場合はまた補足いただければ検討します。

お礼

ありがとうございます。

補足

考察ありがとうございます。Sheet1とSheet2入替え等行ってみたのですがやはり"●○◎"のみ残ります何か案がありましたらよろしくお願いします。

回答No.1

queuerev2

画像が小さくてよく見えないので主に質問文を元に考えました。

たとえば以下のようなものでいかがでしょうか。

Sub シートコピー()
Dim r As Range
For Each r In Worksheets("Sheet1").Range("B1:F10")
If InStr("●○◎", Trim(WorksheetFunction.Clean(Sheets("sheet2").Range(r.Address).Value))) = 0 Then
'↑1行追加（sheet2（表-2)に入力済みの記号の判定は最初に行う。記号がない場合のみコピーする）
If WorksheetFunction.CountIf(Worksheets("Sheet1").Range("A14:A18"), r.Value) Then
'Sheet1以外がアクティブでも正常に動作するようにシートの指定を追加
Sheets("sheet2").Range(r.Address).Value = r.Value
Else
Sheets("sheet2").Range(r.Address).Value = ""
End If
End If '←1行追加（追加したIf文の条件が成り立たないならここまでスキップ）
Next
End Sub

なお、「InStr("●○◎", Trim(WorksheetFunction.Clean(Sheets("sheet2").Range(r.Address).Value))) = 0」の部分は、sheet2に実際に入る可能性のあるデータなどを考えて必要に応じて変更してください。

お礼

ありがとうございます。

補足

コードを入力した結果Sheet2に"●○◎"の記号は残るのですが
Sheet1の記号"A,C,F,H"が入力できません。
何か良い方法があるのでしょうか？
よろしくお願いします。