★EXCEL VBA★２つのシートで一致しているセルに値を代入したい

質問

表題の件で、苦戦しています。
まず２つのシートがありまして下記のようになっています。

１シート目
No　内容
１　おはよう
２　こんにちわ
３　こんばんわ
（コントロール1：オプションボックス　A or B or C）
（コントロール2：実行ボタン）

２シート目（更新後）
No　グループ　内容
１　B　　　　
２　B　　　　
３　B　　　　
１　C　　　おはよう
２　C　　　こんにちわ
３　C　　　こんばんわ

★やりたいこと
１シート目でコントロール１を「C」としてコントロール２の実行ボタンをおした際、２シート目のグループを検索し一致した「No」＆「グループ」の箇所にそれぞれの「内容」を代入する。
また「A」はALL扱いとして、グループは無視し、一致した「No」の箇所に
それぞれ「内容」を代入する。

以上です。ぜひとも宜しくお願いします。

回答No.2

papayuka · ベストアンサー

#1です。

提示されたコードを読んでも解らない部分があり、意味が違うかも知れません。
こちらで試したテスト環境を書きますので、試す場合は同様の環境で試して見て下さい。

1）シート名 Sheet1 の A1:B4 に下記リストがあり、1行目はタイトル行とする。

　　No　内容
　　１　おはよう
　　２　こんにちわ
　　３　こんばんわ

2）シート名 Sheet2 の A1:C7 に下記リストがあり、1行目はタイトル行とする。

　　No グループ　内容
　　１　B　　　　
　　２　B　　　　
　　３　B　　　　
　　１　C　　　　
　　２　C　　　　
　　３　C　　　　

3）シート名 Sheet1 には コントロールツールボックスの CommandButton が１つと OptionButton が３つある。
　 CommandButton1 の Click イベントを下記のようにする。

Private Sub CommandButton1_Click()
Dim op As String, r As Range, fr
　'OptionButton は GroupName が同じとする
　If Me.OptionButton1.Value Then op = "A"
　If Me.OptionButton2.Value Then op = "B"
　If Me.OptionButton3.Value Then op = "C"
　With Worksheets("Sheet2")
　　 '取り合えず実行するたびに C列 をクリアする
　　 .Range("C2", .Range("A65536").End(xlUp).Offset(0, 2)).Clear
　　 'Sheet2をA2からループ
　　 For Each r In .Range("A2", .Range("A65536").End(xlUp))
　　　　 'Sheet1(Me)のA列に完全に一致する値があるかを検索
　　　　 Set fr = Me.Columns("A").Find(what:=r.Value, lookat:=xlWhole)
　　　　 If Not fr Is Nothing Then
　　　　　　'見つかった場合、op の状態によって転記方法を分ける
　　　　　　Select Case op
　　　　　　Case "A"
　　　　　　　 '同じなら全部転記
　　　　　　　 r.Offset(0, 2).Value = fr.Offset(0, 1).Value
　　　　　　Case "B", "C"
　　　　　　　 '条件に合う場合のみ転記
　　　　　　　 If r.Offset(0, 1).Value = op Then
　　　　　　　　　r.Offset(0, 2).Value = fr.Offset(0, 1).Value
　　　　　　　 End If
　　　　　　End Select
　　　　 End If
　　 Next r
　End With
End Sub

お礼

こんばんわ。papayukaさま。お世話になります。
教えて頂いたコードで無事に完成しました。
ありがとうございました。本当に助かりました。

実はシート２の「No」と「グループ」が逆で、
しばらくうまくできなかったのですが、
Offsetで-1したらできました。
また機会がありましたら宜しくお願いします。

回答No.1

papayuka

シート上に置けるオプションボタンやコマンドボタンは2種類あり（コントロールツールボックスとフォーム）それぞれコードの扱い等が違います。

「Aは ALL扱いでグループを無視」って事は、例の通りだとBもCもNoが同じなので下記のような感じで全てのグループに同じ値が入るのでしょうか？

２シート目（更新後）
No　グループ　内容
１　B　　　おはよう
２　B　　　こんにちわ
３　B　　　こんばんわ
１　C　　　おはよう
２　C　　　こんにちわ
３　C　　　こんばんわ

> 苦戦しています。

まる投げっぽく見えちゃいますので、ソースコードを提示してどの辺が上手く行かないかを聞かれた方が良いかも。

補足

ご返信遅くなりすみません。回答します。
コントロールツールボックスを使用しています。
AのALL扱いというのは、BもCもで認識あっており、
（例）に挙げていただいた通りでOKです。

チャレンジしているソースコードを添付します。
まずは値が一致した箇所に代入する。という部分をいろいろ研究しています。

Private Sub CommandButton1_Click()
y = 0
Set d1 = Sheets1
Set d2 = Sheets2
R = d2.Cells(65536, "B").End(xlUp).Row
For i = 1 To R
Set X = d1.Columns("B").Find(What:=d2.Cells(i, "B"), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not X Is Nothing Then
d2.Cells(i, "C") = X.Offset(y, 1)
End If
y = y + 1
Next i
End Sub

これだと、シート１でBと指定した場合、
シート２の結果として、最初にヒットしたBの３レコードみが更新される状態になってしまいます。どこかでカウンタアップさせないとダメみたいです。