エクセル2000-マクロでの文字置き換えの質問です。

質問

エクセル2000を使用しています。
　　 A 　　　B　　　 C 　　 D 　　　　 　・・ X 　　　Y
１　１　　とまと　　４　　なし　　　　　　　1　 とまと
２　　　　　　　　　　　　　　　　　　　　　　2　 　 なす
３　２　　なす　　　５　　りんご　　　　　5　　 きゅうい
４　　　　　　　　　　　　　　　　　　　　　　6　　 ソーセージ
５　３　　きゅうり　６　　えだまめ　　　
６　　　　　　　　　　　　　　　　　　　　
--------------------------------------------------------------
上のような表があります。
A列C列には番号（固定番号）が入っています。
列の間には空白のセルが入っています。（Ｘ・Ｙ列は空白セルなし）
Ｂ列Ｄ列には品名が入っています。
Ｘ列の数字がA列・Ｃ列にあっていたらＹの文字をＢ列・Ｄ列に、
それぞれ、置き換えを行いたいです。
Ｘ列の数字とＹ列の文字は、その都度かわります。
上記のような処理をマクロで行うことは、可能でしょうか？
説明がうまくできていないかも知れませんが、よろしくお願いします。

回答No.2

Wendy02 · ベストアンサー

こんばんは。

単純な方法ですが、こんな風にできるかと思います。

Sub Test1()
　　Dim c As Range
　　Dim f As Range
　　Dim rng As Range
　　Set rng = Range("A1", Range("D65536").End(xlUp))
　　For Each c In Range("X1", Range("X65536").End(xlUp))
　　　　If IsNumeric(c.Value) Then
　　　　　　Set f = rng.Find(c.Value, LookIn:=xlValues, LookAt:=xlWhole)
　　　　　　If Not f Is Nothing Then
　　　　　　　　If f.Offset(, 1).Value <> c.Offset(, 1).Value Then
　　　　　　　　　　f.Offset(, 1).Value = c.Offset(, 1).Value
　　　　　　　　End If
　　　　　　End If
　　　　End If
　　Next
　　Set rng = Nothing
End Sub

お礼

ご返答大変ありがとうございます。
すぐに試せればよいのですが、当方の事情により
すぐに試すことができません。
明日、早急に試してみます。
（このような環境で、大変申し訳ありません。）
はじめて、投稿してみてこんなにも早くご回答がくるとは
正直おどろいています。
どうもありがとうございました。
取り急ぎ、お礼を申し上げます。

回答No.3

imogasi

実例も挙げてあり説明も有る。しかしVBAでやりたいなら、処理手順を文章で書き上げてご覧（下記に例を示す）。
そうすればどこがVBAコード化（作成）にあったって、行き詰まっているのか、質問点を絞れるでしょう。
質問では丸投げで、回答者にコードを書かせ、その回答をやってみて、テストする試験者のようで、このコーナーは回答者は試験を受けているのではないが、そのような風になる。
例　
１．A列の数の行A1を捉える。
２．A1とX1と比べる。合えばY1をB1に代入する。
そしてA列の次の行に処理を移す（２行おきにデータがあるのか？）
３．合わない場合はX2と比べる（以下合わない場合はX列の最後セルまで比較を繰り返す）
４．次の行セルA3に着いて１－３を繰り返す。
ーー
５A列の最終行データまで処理が終わったら、B列の処理に移る。
それには上記のコードのCells(1,1）をCells(i,2)に変えて繰り返す。For　Nextなどで、２重ループで出来る。
最下行の捉え方は判るのかな。
A,Bの最下行は異なるのかな。
ーーー
上記では、何も難しいコードになる見当はない。
総当りは泥臭いが、初心者ならやむをえない。その点を改良したいなら、そのように質問点を絞って質問に書くべきだ。

お礼

ご返答大変ありがとうございました。
記述例のとおり、きちんと整理して質問に当たるべきでした。
不快な思いをさせてしまい、大変申し訳ありません。
（私自身ぜんぜん整理されていないのに、質問してしまい失礼でした。）
今後は、例を参考に質問させていただきます。

回答No.1

n-jun

Sub try()
Dim myDic As Object
Dim r As Range
Dim i As Long
Dim v

Set myDic = CreateObject("Scripting.Dictionary")

v = Range("X1", Cells(Rows.Count, "Y").End(xlUp)).Value

For i = 1 To UBound(v, 1)
myDic(v(i, 1)) = v(i, 2)
Next

For Each r In Range("A:A,C:C").SpecialCells(xlTextValues)

If myDic.Exists(r.Value) Then
r.Offset(, 1).Value = myDic(r.Value)
End If

Next

Set myDic = Nothing
Erase v
End Sub

例えばこうゆう事ですか？

お礼

とても、はやいご返答大変ありがとうございます。
当方の都合により、すぐに試すことができませんが、
明日早急に試してみたいとおもいます。
（このような、作業環境で大変申し訳ありません。）
取り急ぎ、お礼を申し上げます。