Bei Zelländerung, nehmen Sie den aktiven Zellenwert und suchen Sie nach dem Wert in einer Spalte?

Question

Ich habe zwei Blätter:

Blatt 1

Column D (Supplier) 
General Mills 
Frenchie 
Marks LTD 

Blatt 2

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

Ich versuche, ein Makro, wenn der Benutzer auf den Namen eines Lieferanten in Spalte D zu laufen, Blatt 1. Dieses Makro sollte den Wert aus der aktiven Zelle in der Spalte D (dem Lieferantennamen) übernehmen und in Spalte D auf Blatt 2 suchen.

Wo der Name des Lieferanten ist ähnlich wie in Blatt 2, dann möchte ich das Meldungsfeld den Namen der Kontaktperson aus Spalte E anzeigen:

Hier ist, was ich im Moment habe, ich bin ziemlich neu in VBA, so bitte kann mir jemand zeigen, wie ich das mache, was ich brauche?

Code:

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

Sie diese Methode verwenden können, um zu erreichen, dass aber Sie es müssen aktualisiert werden, da es für die genaue ganze Wort sucht. ändern xlWhole zu xlPartial zu lösen, dass

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

dieser Code Blatt des auf Sheet1 Put:

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 

Beachten Sie, dass Teil-Suche nur einen Weg, arbeiten. Der Wert von Sheet1 muss ein Teilstring von Sheet2 sein.

Answer 3

Ich schaffte es, am Ende etwas sehr ähnliches zu machen und fügte ein paar weitere luxuriöse Code-Stücke hinzu!

habe ich den folgenden Code:

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