セルの変更時に、アクティブなセルの値を取り、列の値を検索しますか？

Question

私が持っている2枚：

シート1

Column D (Supplier) 
General Mills 
Frenchie 
Marks LTD 

シート2

Column D (Supplier)  Column E (Contact) 
General Mills LTD  Jane 
FrenchieS    Mike 
Marks     Parker 

私はマクロを実行しようとしていたときに、列Dにおけるサプライヤーの名前にユーザーの種類、このマクロは、列D（供給元名）のアクティブセルの値をとって、シート2の列Dでこれを検索する必要があります。

ここで、サプライヤの名前はシート2のものと似ています。次に、メッセージボックスに列Eの担当者の名前を表示します。

これは私が現時点で持っているものです。誰かが私に必要なことをする方法を教えてください。

コード：

Private Sub Worksheet_Change(ByVal Target As Range) 
If Not Intersect(Target, ThisWorkbook.Worksheets(1).Range("D" & ActiveCell.Row)) Is Nothing Then Exit Sub 
Application.EnableEvents = False 'to prevent endless loop 
On Error GoTo Finalize 'to re-enable the events 

'Start lookup 
ThisWorkbook.Worksheets("Contacts").Columns("D:D").Select 
    Set cell = Selection.Find(What:=ThisWorkbook.Worksheets(1).Range("D" & ActiveCell.Row).Value, LookIn:=xlValues, _ 
     LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ 
     MatchCase:=False, SearchFormat:=False) 

If cell Is Nothing Then 

Exit Sub 

Else 
MsgBox "Found" 
End If 



Finalize: 
Application.EnableEvents = True 
End Sub 

Answer 1

あなたはそれが正確な単語全体を探しているので、あなたはそれを更新する必要があるかもしれませんがそれを達成するために、このメソッドを使用することができます。部分的な検索が一方向にしか機能していること

Private Sub Worksheet_Change(ByVal rTarget As Range) 
    If rTarget.Column = 4 Then 
     Set Result = Sheets("Sheet2").Range("D:D").Find(What:=rTarget, LookIn:=xlValues, LookAt:=xlPartial) 
     If Not Result Is Nothing Then 
     MsgBox Result.Offset(0, 1) 
     End If 
    End If 
End Sub 

注：

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) 
'check to make sure we are in the right worksheet 
If Target.Worksheet.Name = ThisWorkbook.Sheets("Supplier Sheet name").Name Then 
    'check to make sure we are in column D 
    If Target.Column = 4 Then 
    Dim ws As Worksheet 
    Dim cell As Range 
    'get the contacts worksheet 
    Set ws = ThisWorkbook.Sheets("Contacts") 
     'look in the cells 
     Set cell = ws.Cells.Find(What:=Target.Value, LookIn:=xlValues, _ 
     LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ 
     MatchCase:=False, SearchFormat:=False) 
    End If 
    'check to see if we found something 
    If cell Is Nothing Then 
     Exit Sub'nothing found so exit 
    Else 
     'we found something so show the value in the cell next to it - Column E 
     MsgBox cell.Offset(0, 1).Value 
    End If 

End If 
End Sub 

Answer 2

は、シート1のコードシートの上にこれを置くことを解決するためにxlPartialにxlWholeを変更します。 Sheet1の値は、Sheet2の部分文字列である必要があります。

Answer 3

私はこれを最終的には非常に似たようにすることができましたし、さらに豪華なコードをいくつか追加しました！右、あなたが一致していない業者の名前を知っている（うまくいけば、これは他の誰かに有用であることが分かるだろう）

Private Sub Worksheet_SelectionChange(ByVal Target As Range) 
Dim Contact As String 
Dim Email As String 
Dim Phone As String 
Dim Fax As String 

Application.EnableEvents = False 'to prevent endless loop 
On Error GoTo Finalize 'to re-enable the events 

If Intersect(Target, ThisWorkbook.Worksheets(1).Range("E" & ActiveCell.Row)) Is Nothing Then 'Main IF 
ActiveSheet.Shapes("Suggest").Visible = False 
ActiveSheet.Shapes("Close").Visible = False 
ActiveSheet.Unprotect Password:="SecretPassword" 
Else 
If ThisWorkbook.Worksheets(1).Range("D" & ActiveCell.Row).Value = "" Then ' Secondary iF 
ActiveSheet.Shapes("Suggest").Visible = False 
ActiveSheet.Shapes("Close").Visible = False 
ActiveSheet.Unprotect Password:="SecretPassword" 
Else 


'Start FIND 
With Worksheets(2).Range("D2:D100") 
Set c = .Find("*" & ActiveCell.Offset(0, -1).Value & "*", LookIn:=xlValues) 
If c Is Nothing Then 

'Introduce FailSafe, escape code if no result found 
ActiveSheet.Shapes("Suggest").Visible = False 
ActiveSheet.Shapes("Close").Visible = False 
ActiveSheet.Unprotect Password:="SecretPassword" 


Else 

'Check values are not blank 
If c.Offset(0, 1).Value <> "" Then 
Contact = "Contact: " & c.Offset(0, 1).Value & vbNewLine 
Else 
Contact = "" 
End If 

If c.Offset(0, 2).Value <> "" Then 
Email = "Email: " & c.Offset(0, 2).Value & vbNewLine 
Else 
Email = "" 
End If 

If c.Offset(0, 3).Value <> "" Then 
Phone = "Phone: " & c.Offset(0, 3).Value & vbNewLine 
Else 
Phone = "" 
End If 

If c.Offset(0, 4).Value <> "" Then 
Fax = "Fax: " & c.Offset(0, 4).Value 
Else 
Fax = "" 
End If 


'Show Contacts 
ActiveSheet.Shapes("Suggest").TextFrame.Characters.Text = "Hello," & vbNewLine & vbNewLine & "Have you tried to contact " & ActiveCell.Offset(0, -1).Value & " about your issue?" & vbNewLine & vbNewLine _ 
& Contact & Email & Phone & Fax 

ActiveSheet.Shapes("Suggest").TextFrame.AutoSize = True 
CenterShape ActiveSheet.Shapes("Suggest") 
RightShape ActiveSheet.Shapes("Close") 
ActiveSheet.Shapes("Suggest").Visible = True 

'Show Close Button 
ActiveSheet.Shapes("Close").OnAction = "HideShape" 
ActiveSheet.Shapes("Close").Visible = True 

'Protect sheet 
ActiveSheet.Protect Password:="SecretPassword", userinterfaceonly:=True 
ActiveSheet.Shapes("Suggest").Locked = True 





End If 
End With 

End If ' End Main If 
End If ' End Secondary If 

Finalize: 
Application.EnableEvents = True 
End Sub 


Public Sub CenterShape(o As shape) 
o.Left = ActiveWindow.VisibleRange(1).Left + (ActiveWindow.VisibleRange.Width/2 - o.Width/2) 
o.Top = ActiveWindow.VisibleRange(1).Top + (ActiveWindow.VisibleRange.Height/2 - o.Height/2) 
End Sub 

Public Sub RightShape(o As shape) 
o.Left = ActiveSheet.Shapes("Suggest").Left + (ActiveSheet.Shapes("Suggest").Width/1.01 - o.Width/1.01) 
o.Top = ActiveSheet.Shapes("Suggest").Top + (ActiveSheet.Shapes("Suggest").Height/30 - o.Height/30) 
End Sub