Установите динамический диапазон (или массив) в строках с дублированными идентификаторами и выделите уникальные значения по нескольким критериям в каждом диапазоне

Question

Данные находятся в одном листе Excel с именем Sheet1, Col A имеет идентификатор человека.Этот идентификатор может быть уникальным, хотя иногда он повторяется от 2 до 5 раз.В каждом случае я хочу установить диапазон (или массив) для каждого идентификатора, включая ячейки в следующих столбцах B, C, D и E. Для которых я хочу проверить Дубликаты в названии (B) Должность (C) Старшинство (D)и Источник этих данных (E-, который будет уникальным для каждой позиции) в пределах каждого заданного диапазона (или массива).Это покажет мне, изменил ли человек должность, имя или стаж работы, так как в каждом списке 2 списка (список 2018 и список 2019) и 3 подкатегории (департаменты B, C, D).Например, человек, который все еще продолжает работать в той же должности в отделе B, будет иметь 2 строки с одинаковыми данными, за исключением столбца E, в котором будет отображаться «2018 Список B» в строке 1 и «2019 список B».«в строке 2. Выделение дубликатов - это самое первое, что нужно сделать для столбцов А и В, поскольку это помогает визуально и легче найти постоянных сотрудников.На данный момент у меня есть подход конкатенации, так как все данные должны быть отображены, и никакие удаления не должны происходить.Поэтому столбец E объединяется, когда все предыдущие столбцы в точности совпадают.Это разрезает данные пополам, и мне нужно только взглянуть на столбец E, чтобы найти меньшую строку текста, чтобы увидеть, что предотвратило объединение, что может быть несовпадением в 1 или более столбцах.Например, смена имени, изменение должности или старшинства.Тем не менее, я все еще не могу отследить, что помешало объединению некоторых дубликатов, так как это усложняется при смене должности, поскольку сотрудник может иметь более 1 должности и может получить или потерять позицию.Кроме того, сотрудник может быть новым или не возвращаться, это определяется столбцом E на основе данных «2018» и «2019».

Надеюсь, что следующее поможет кому-то в будущем.Чтобы следующий код работал, таблица должна быть отсортирована так, чтобы каждая строка имела равный справа под ним, как можно ближе.

    Sub ConcatenateData()

    With Worksheets("Sheet1")
        With .Cells(2, "A").CurrentRegion
            .Cells.Sort Key1:=.Range("A3"), Order1:=xlAscending, _
                        Key2:=.Range("C3"), Order2:=xlAscending, _
                        Key3:=.Range("D3"), Order3:=xlAscending, _
                        Orientation:=xlTopToBottom, Header:=xlYes
        End With
    End With

    Dim my Rng As Range
    Dim prevRow As Range, myRow As Range
    Dim comparePrev As Range, comp As Range
    Dim prevData As Range, myData As Range
    Dim myIndex As Integer, numColumns As Integer

    Set myRng = ActiveCell.CurrentRegion
    numColumns = myRng.Columns.Count
    Set prevRow = myRng.Rows(1)
    myIndex = 2

    Do While myIndex <= myRng.Rows.Count
        Set myRow = myRng.Rows(myIndex)

        'Get all the cells from myRow except the last one
        Set comp = myRow.Resize(1, numColumns - 1)
        Set comparePrev = prevRow.Resize(1, numColumns - 1)

        If SameRanges(comp, comparePrev) Then

            'If  myData is the last cell from myRow
            Set myData = myRow.Cells(numColumns) 'Set myData = myRow.Offset(0, numColumns - 1).Resize(1, 1)
            Set prevData = prevRow.Cells(numColumns) 'Set prevData = prevRow.Offset(0, numColumns - 1).Resize(1, 1)

            ‘Group myData and delete myRow
            prevData.Value = prevData.Value & ", " & myData.Value
            myRow.Delete
        Else
            Set prevRow = myRow
            myIndex = myIndex + 1
        End If
    Loop


End Sub



'To compare ranges



Function SameRanges(range1 As Range, range2 As Range) As Boolean
'Return true if both ranges are the same

    Dim myIndex As Integer
    Dim cell1 As Range
    Dim cell2 As Range

    If range1.Cells.Count <> range2.Cells.Count Then
        SameRanges = False
        Exit Function
    End If

    For myIndex = 1 To range1.Cells.Count
        Set cell1 = range1.Cells(myIndex)
        Set cell2 = range2.Cells(myIndex)
        If cell1.Text <> cell2.Text Then
            SameRanges = False
            Exit Function
        End If
    Next
    SameRanges = True
End Function

``````````````