Использование Excel VBA для поиска точного совпадения нескольких столбцов, а затем объединение / слияние строк

Question

Мне сказали повторно опубликовать это с большим количеством данных и кода, поэтому здесь мы go. Надеюсь, на этот раз это удовлетворительно.

Я пытаюсь взять базу данных Excel и объединить / объединить соответствующие столбцы в одну строку с помощью VBA. Исходные данные будут выглядеть примерно так (в действительности существует гораздо больше точек данных, и я бы совпал по большему количеству столбцов и объединил бы больше строк):

Исходные данные

И превратить его в такой, который выглядит следующим образом:

Объединенные данные

Что мне нужно сделать, так это точно сопоставить столбцы A: E (State, Last, First, Age, Class) и, если они есть, объединить / объединить столбцы F: I (20 ', 19', 18 ', 17' ) в один ряд. Кроме того, я хотел бы удалить информацию из столбцов, которые она объединяет / объединяет (F: I) в одной из строк. Например, с слиянием / объединением Роберта Джонсона; Если вы посмотрите на приведенную выше таблицу, в одной строке содержится вся информация от F: I, но в обеих строках все еще есть вся информация от A: E.

Ближайший, к которому я смог ее получить, работа заключается в использовании кода (который я нашел в другом месте и не создал):

[COLOR=#008000]'Dim 2 search cells[/COLOR]
Dim BlankCell As Range
Dim IdCell As Range

[COLOR=#008000]
'Find Last row and column[/COLOR]

Dim lRow As Long
lRow = Range("A1").End(xlDown).Row
Dim lColumn As Long
lColumn = Range("A1").End(xlToRight).Column

[COLOR=#008000]'Set the area to consider[/COLOR]

Dim Rng As Range
Set Rng = Range(Cells(1, 1), Cells(lRow, lColumn))

[COLOR=#008000] 'Select​ each blank cell in area[/COLOR]

Rng.Select
Selection.SpecialCells(xlCellTypeBlanks).Select

 [COLOR=#008000]'And replace it with appropriate value[/COLOR]
    For Each BlankCell In Selection
             For Each IdCell In Range(Cells(1, 1), Cells(lRow, 1))
                      If (IdCell.Value = Cells(BlankCell.Row, 1).Value And Cells(IdCell.Row, BlankCell.Column) <> "") Then
                        BlankCell = Cells(IdCell.Row, BlankCell.Column).Value
                      End If
             Next IdCell
    Next BlankCell

[COLOR=#008000] 'Then​ erase duplicate lines[/COLOR]
    Rng.Select
    ActiveSheet.Range(Cells(1, 1), Cells(lRow, lColumn)).RemoveDuplicates     Columns:=Array(1, 2, 3, 4, 5, 6), _
    Header:=xlYes

Хотя он не совпадает правильно, потому что вывод выглядит так:

Не совсем верно

Похоже, что он совпадает только в первом столбце, а не в первом 5. Он также не объединяет / удаляет право на данные.

Ценю любую помощь!