在“单元格更改”上，获取活动单元格值并在列中search值？

我有两张床单：

表1

Column D (Supplier) General Mills Frenchie Marks LTD 

工作表2

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

我试图运行一个macros，当用户在列D，表1中的供应商的名称中键入此macros应从D列（供应商名称）的活动单元格中的值，并在D列中search表2

如果供应商名称与表2中的相似，那么我希望消息框显示列E中联系人的名称：

这里是我现在所拥有的，我对VBA很新，所以请有人告诉我如何得到这个来做我需要的？

码：

 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

您可以使用此方法来完成，但是您可能需要更新它，因为它正在查找完整的单词。 将xlWhole更改为xlPartial以解决该问题

 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

把这个放在Sheet1的代码表上：

 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 

请注意，部分search只能以一种方式进行。 Sheet1的值需要是Sheet2的子string。

Answer 3

我设法得到这个最后做一些非常相似的东西，并添加一些更多的豪华代码片段！

我用了下面的代码：（希望这会certificate对别人有用）

 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