Блог

У меня есть список имен людей в столбце (на листе 12), и в этом столбце в каждой ячейке может быть один или несколько человек, разделенных запятой и и alt enter. Что я хочу сделать, так это взять содержимое этого столбца, преобразовать его в список электронных писем, а затем преобразовать его в одну строку, в которой есть только уникальные записи с адресами электронной почты людей (т. Е. Если имя повторяется в столбце, после добавления электронной почты людей оно больше не включается в строку).

Я хотел бы избежать включения дополнительной колонки в лист с электронными письмами, поэтому у меня есть еще одна вкладка со списком имен людей по их адресам электронной почты, с которыми я использовал сопоставление индексов для получения электронных писем.

Приведенный ниже код-единственный способ, которым я могу это сделать, но по мере увеличения числа людей в каждой ячейке увеличивается количество возможных комбинаций, поэтому создание становится слишком громоздким, поэтому я пришел сюда в надежде, что есть способ преодолеть это.

 Sub Macro1()

Dim i As Integer
Dim P As Integer
Dim Email_To As String
Dim Email_Rng As Range
Dim Num_of_Emails As Integer
Dim Last_Cell_TWDS As Integer
Dim Last_Cell_TWDP As Integer
Dim Last_Cell_RCAR As Integer
Dim Last_Cell_Specs As Integer
Dim Last_Cell_Minutes As Integer
Dim First_Row As Integer
Dim Owner_Column As Integer
Dim Email_Check As String
Dim Email_Check_P1 As String
Dim Email_Check_P2 As String
Dim Email_Check_P3 As String
Dim Email_Check_P4 As String
Dim Num_People_Cell As Integer
Dim Cell_Value As String
Dim P1 As String
Dim P2 As String
Dim P3 As String
Dim P4 As String

'Setting Email to to empty
Email_To = ""

'Email to TWDS
    Sheet12.Select
    Last_Cell_TWDS = Range("Admin!U2").Value
    First_Row = 5
    Owner_Column = 5
    Email_Check = ""
    
    For i = First_Row To (Last_Cell_TWDS   4)
    
    If Cells(i, Owner_Column).Value <> "" Then 'check if the cell is empty and if not set the cell value to check the email
        
        Num_People_Cell = Len(Cells(i, Owner_Column).Value) - Len(Replace(Cells(i, Owner_Column).Value, ",", ""))   1 ' Checking the number of people in the cell using the number of commas
        
    End If
    
        If Cells(i, Owner_Column).Value <> "" Then 'check if the cell is empty and if not set the cell value to check the email

            For P = 1 To Num_People_Cell '  1 because 2 people = 1 comma
            
               If P = 1 Then '////////////////////////////////////////////////////////////////////////////////////////////1 Person
               
                    If Num_People_Cell = 1 Then
                    
                        Email_Check = WorksheetFunction.Index(Range("Admin!Q4:Q200"), WorksheetFunction.Match(Cells(i, Owner_Column).Value, Range("Admin!P4:P200"), 0)) 'define what the current email is for the name in the cell
                        
                    End If
            
                     If Cells(i, Owner_Column).Value = "" Then ' if the cell is Blank do nothing
                         Email_To = Email_To
             
                     ElseIf Email_To = "" Then 'if the cell is not blank then take the contents of the cell and add it to email_To string
                     
                             Email_To = Email_To amp; WorksheetFunction.Index(Range("Admin!Q4:Q200"), WorksheetFunction.Match(Cells(i, Owner_Column).Value, Range("Admin!P4:P200"), 0))
                         
                     ElseIf InStr(1, Email_To, Email_Check) <> 0 Then 'if Email_To is not blank then check if the cell value is already in the Email_To string
                         
                             Email_To = Email_To
                         
                     Else
                         
                         Email_To = Email_To amp; "; " amp; WorksheetFunction.Index(Range("Admin!Q4:Q200"), WorksheetFunction.Match(Cells(i, Owner_Column).Value, Range("Admin!P4:P200"), 0))
                         
                    End If
                 
                ElseIf P = 2 Then '////////////////////////////////////////////////////////////////////////////////////////////2 People
                 
                     'define the two peoples names
                     P1 = Left(Cells(i, Owner_Column).Value, InStr(1, Cells(i, Owner_Column).Value, ",") - 1)
                     P2 = Right(Cells(i, Owner_Column).Value, (Len(Cells(i, Owner_Column).Value) - 3 - InStr(1, Cells(i, Owner_Column).Value, ",")))
                     Email_Check_P1 = WorksheetFunction.Index(Range("Admin!Q4:Q200"), WorksheetFunction.Match(P1, Range("Admin!P4:P200"), 0)) 'define what the current email is for the name in the cell
                     Email_Check_P2 = WorksheetFunction.Index(Range("Admin!Q4:Q200"), WorksheetFunction.Match(P2, Range("Admin!P4:P200"), 0)) 'define what the current email is for the name in the cell
                     
                     If Email_To = "" Then 'if the cell is not blank then take the contents of the cell and add it to email_To string
                     
                             Email_To = P1 amp; "; " amp; P2
                         
                    ElseIf InStr(1, Email_To, Email_Check_P1) <> 0 And InStr(1, Email_To, Email_Check_P2) <> 0 Then
                         
                         Email_To = Email_To
                         
                    ElseIf InStr(1, Email_To, Email_Check_P1) = 0 And InStr(1, Email_To, Email_Check_P2) = 0 Then
                         
                         Email_To = Email_To amp; "; " amp; WorksheetFunction.Index(Range("Admin!Q4:Q200"), WorksheetFunction.Match(P1, Range("Admin!P4:P200"), 0)) amp; "; " amp; WorksheetFunction.Index(Range("Admin!Q4:Q200"), WorksheetFunction.Match(P2, Range("Admin!P4:P200"), 0))
                    
                    ElseIf InStr(1, Email_To, Email_Check_P1) > 0 Then
                         
                         Email_To = Email_To amp; "; " amp; WorksheetFunction.Index(Range("Admin!Q4:Q200"), WorksheetFunction.Match(P1, Range("Admin!P4:P200"), 0))
                         
                    ElseIf InStr(1, Email_To, Email_Check_P2) > 0 Then
                         
                         Email_To = Email_To amp; "; " amp; WorksheetFunction.Index(Range("Admin!Q4:Q200"), WorksheetFunction.Match(P2, Range("Admin!P4:P200"), 0))
                         
                    End If

                End If
            
            Next P
        
        End If
        
    Next i

End Sub
 

Это может быть способ справиться с этим:

ПРАВКА: добавлено получение одной строки со всеми уникальными письмами

 Sub Tester()
    
    Dim c As Range, v, arr, nm, email, emails, sep
    Dim dict As Object, rngEmails As Range
    
    Set dict = CreateObject("scripting.dictionary") 'for tracking unique values
    
    'email lookup table: name|email
    Set rngEmails = ThisWorkbook.Sheets("Admin").Range("P4:Q4")

    For Each c In sheet12.Range("E5:E" amp; sheet12.Cells(Rows.Count, "E").End(xlUp).Row)
        v = c.Value
        If Len(v) > 0 Then                    'ignore empy cells
            v = Replace(v, vbLf, ",")         'get a single thing to split on...
            arr = Split(v, ",")               'get an array of names
            For Each nm In arr                'loop over the array
                nm = Trim(nm)                 'remove leading/trailing spaces
                If Not dict.exists(nm) Then   'if a new name then get the email
                    email = Application.VLookup(nm, rngEmails, 2, False)
                    If Not IsError(email) Then
                        dict(nm) = email
                    Else
                        Debug.Print "No email found for '" amp; nm amp; "'"
                    End If
                End If
            Next nm
        End If
    Next c

    emails = Join(dict.items, ";") 'get single string from dictionary items
    'do something with `emails`
    
End Sub