从基于另一个单元格的Dupes列中仅拉出一个唯一项

Question

我有一张看起来像这样的表：

我有VBA代码，用于启动电子邮件并从工作表中获取数据，并根据工作表中搜索的输入框值将其放入电子邮件正文中。根据查找该值从行中获取值。我现在遇到的麻烦是我们有很多欺骗，我想只拉一个名字，然后让它循环，当它点击一个新的批准者名称时创建一个新的电子邮件，然后抓住所有那个< / em>批准者的客户，等等。

以上表格中的示例： 电子邮件说＆＃39;亲爱的克里斯， 您的客户Thomas，Mark和Jared都需要接受审核。＆＃34;

所以我需要代码将所有客户（C列）分配给一个批准者（E栏），但只抓取每个客户名称的一个实例。

然后，它会在找到下一个批准者时创建一个新的单独的电子邮件，在本例中为John。因此，批准者名称成为分隔符。

我不确定如何做到这一点，或者什么是最好的方法。任何人都可以提出任何想法吗？我正在学习，但这部分给了我麻烦。 这是我到目前为止的代码：

Sub Test()
Dim aOutlook As Object
Dim aEmail As Object
Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
Dim strbox As String
Dim stritem As String
Dim x As Long
Dim r As Long
Dim lr, lookRng As Range
Dim findStr As String
Dim foundCell As Variant
Dim foundcell1 As Variant
Dim foundcell2 As Variant
Dim strbody As String
Dim sigstring As String
Dim signature As String
Dim findstr1 As String
Dim foundrng As Range
Dim valuefound As Boolean
Dim strFilename As String

Set aOutlook = CreateObject("Outlook.Application")
Set aEmail = aOutlook.CreateItem(0)

'Input box(es)

findStr = InputBox("Enter approver name to find")

'Greeting based on time of day

Select Case Time
       Case 0.25 To 0.5
            GreetTime = "Good morning"
       Case 0.5 To 0.71
            GreetTime = "Good afternoon"
       Case Else
            GreetTime = "Good evening"
 End Select

'Search for input box values and set fields to be pulled

lr = Cells(Rows.Count, "c").End(xlUp).Row
Set lookRng = Range("d1:d" & lr)
 valuefound = False
 For x = 1 To lr
   If Range("c" & x).Value = findStr Then
    Set foundCell = Range("B" & x).Offset(0, 4)
    Set foundcell1 = Range("e" & x).Offset(0, 1)
    Set foundcell2 = Range("B" & x).Offset(0, 5)
    valuefound = True
   End If
 Next x

'Ends the macro if input values to not match the sheet exactly

   If Not valuefound Then
    MsgBox "Is case-sensitive, Must be exact name", vbExclamation, "No     
 Match!"
    Exit Sub
    End If 

Answer 1

我接近这个的方法是使用SQL查询您的表以排除任何重复项（我改编this示例），然后使用字典迭代返回的记录集以存储您的批准者及其客户。

为了让下面的示例正常工作，我添加了Microsoft ActiveX Data Objects 6.1库（用于SQL）和Microsoft Scripting Runtime（用于字典），我相信它可以满足您的需求：

Sub GetApproversAndCustomers()
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset

strFile = ThisWorkbook.FullName
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"

Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")

cn.Open strCon

'only retrieve unique combinations of approvers and customers
strSQL = "SELECT DISTINCT [Approver Name],[Customer Name] FROM [Sheet1$B1:E11]"

rs.Open strSQL, cn

Dim approvers As Dictionary
Set approvers = New Dictionary

Do Until rs.EOF
    'only add the approver to the collection if they do not already exist
    If approvers.Exists(rs.Fields("Approver Name").Value) = False Then
        'if they dont exist, add both the approver and customer to the dictionary
        approvers.Add rs.Fields("Approver Name").Value, rs.Fields("Customer Name").Value
    Else
        'if they do exist, find the approver and add the customer to the existing list
        approvers.Item(rs.Fields("Approver Name").Value) = approvers.Item(rs.Fields("Approver Name").Value) & ", " & rs.Fields("Customer Name").Value
    End If
    rs.MoveNext
Loop

'iterate over the dictionary, outputting our values
Dim strKey As Variant
For Each strKey In approvers.Keys()
    Debug.Print "Dear " & strKey & ", Your customer(s) " & approvers(strKey) & " all need to be reviewed."
Next
End Sub

Answer 2

这是一个不使用SQL的版本，我希望它比上一个更好！

它循环遍历表，直到没有更多的数据行。它创建一个批准者字典并添加相应的客户（使用偏移方法），除非已经添加了该客户。

Option Explicit

Public Function GetApproversAndCustomers2(ByVal approversColumn As String, ByVal customerNameColumn As String)
Dim approvers As Object
Set approvers = CreateObject("Scripting.Dictionary")

Dim iterator As Integer
iterator = 2

Do While Len(Sheet1.Range(approversColumn & iterator).Value) > 0
Dim approver As String
approver = Sheet1.Range(approversColumn & iterator).Value

If Not approvers.Exists(approver) Then
    If Len(approver) > 0 Then
        approvers.Add approver, Sheet1.Range(approversColumn & iterator).Offset(0, -2)
    End If
Else
    If InStr(1, approvers.Item(approver), Sheet1.Range(approversColumn & iterator).Offset(0, -2).Value) = 0 Then
        approvers.Item(approver) = approvers.Item(approver) & ", " & Sheet1.Range(approversColumn & iterator).Offset(0, -2).Value
    End If
End If
iterator = iterator + 1
Loop

iterator = 2

Dim key As Variant
For Each key In approvers.Keys
Debug.Print "Dear " & key & ", Your customer(s) " & approvers(key) & " all need to be reviewed."
Next
End Function