Как объединить 2 функции VBA на основе условия 1 функции?

Question

У меня есть набор данных, в котором контактная информация и имена соотносятся с компаниями, в которых работал человек. 1 человек может быть связан со многими компаниями. Я хочу объединить информацию об отдельных лицах, но сохранить информацию о разных названиях компаний.

У меня есть функция VBA, которая может удалять дубликаты строк (имя и контактная информация), и другая функция VBA, которая может объединять две отдельные ячейки (названия компаний) в одну объединенную ячейку. Данные не сортируются по какому-либо конкретному полю.

Я хотел бы создать функцию, которая будет удалять дубликаты строк, И ЗАТЕМ объединять ячейки с названием компании, НО ТОЛЬКО ДЛЯ людей, у которых удалены повторяющиеся строки (это означает, что человек связан с более чем одной компанией).

Спасибо за любую помощь!

Пример формата исходных данных:

this is the function and result of VBA function 1:

Sub RemoveDuplicates()
'UpdatebyExtendoffice20160918
 
    Dim xRow As Long
    Dim xCol As Long
    Dim xrg As Range
    Dim xl As Long
    On Error Resume Next
    Set xrg = Application.InputBox("Select a range:", "Kutools for Excel", _
                                    ActiveWindow.RangeSelection.AddressLocal, , , , , 8)
 
    xRow = xrg.Rows.Count + xrg.Row - 1
    xCol = xrg.Column
    'MsgBox xRow & ":" & xCol
    Application.ScreenUpdating = False
    For xl = xRow To 2 Step -1
        If Cells(xl, xCol) = Cells(xl - 1, xCol) Then
            Cells(xl, xCol) = ""
        End If
    Next xl
    Application.ScreenUpdating = True
    
End Sub

Function 2 is below and the module just concatenates and merges cells, but I don't know how to write a function that will only apply where the individual has had duplicate rows removed (meaning that individual is associated with multiple companies).

Sub MergeCells()
    Dim xJoinRange As Range
    Dim xDestination As Range
        
    Set xJoinRange = Application.InputBox(prompt:="Highlight source cells to merge", Type:=8)
    Set xDestination = Application.InputBox(prompt:="Highlight destination cell", Type:=8)
    temp = ""
    For Each Rng In xJoinRange
        temp = temp & Rng.Value & " "
    Next
    xDestination.Value = temp
End Sub

    
    

введите описание изображения здесь

Answer 1

Я бы подошел к этому иначе и использовал бы Power Query, доступный в Excel 2010 +.

Power Query как метод «Группировать по», где вы можете выбрать столбцы, которые хотите сгруппировать, - в вашем случае это будут все столбцы, кроме столбца Компания . Затем вы можете объединить столбец компании, используя перевод строки, и получить желаемый результат.

• Data --> Get & Transform Data --> From Table/Range

• Выберите все столбцы, кроме Company и Group By

• Операция All Rows

• Add Custom Column (to split out the company names with formula:
  • Table.Column([Grouped],"Company")

• Select the Double-headed arrow at the top of the custom column
  • Extract values from list
  • Use the line feed for the separator #(lf)
• Close and Load to

You may have to do some custom formatting for the phone number, and also set Word Wrap for the company column.

Here is the generated MCode:

let
    Source = Excel.CurrentWorkbook(){[Name="Table3"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"Email", type text}, {"Phone", Int64.Type}, {"First Name", type text}, {"Last Name", type text}, {"Company", type text}}),
    #"Grouped Rows" = Table.Group(#"Changed Type", {"Email", "Phone", "First Name", "Last Name"}, {{"Grouped", each _, type table [Email=text, Phone=number, First Name=text, Last Name=text, Company=text]}}),
    #"Added Custom" = Table.AddColumn(#"Grouped Rows", "Company", each Table.Column([Grouped],"Company")),
    #"Extracted Values" = Table.TransformColumns(#"Added Custom", {"Company", each Text.Combine(List.Transform(_, Text.From), "#(lf)"), type text})
in
    #"Extracted Values"

And here are the results:

введите описание изображения здесь