Sub dс()
Dim dic As Object
Dim ShtK As Worksheet

    Application.ScreenUpdating = False 'отключаем обновление экрана
    Application.Calculation = xlCalculationManual 'отключаем автоматический пересчёт формул после каждого действия с листом
    Application.EnableEvents = False 'отключаем отслеживание событий

Set ShtK = Workbooks("Согласование заказа в 1С.xlsm").Worksheets("TDSheet")
ShtK.Range("F2:I100000").ClearContents 'очищаем поля перед вставкой новых значений

Set dic = CreateObject("Scripting.Dictionary")

For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    If Cells(i, 3).Value = "На согласовании" Or Cells(i, 3).Value = "Отклонен" Or Cells(i, 3).Value = "Ошибка обмена" Or Cells(i, 3).Value = "Ожидание синхронизации" Or Cells(i, 3).Value = "Отменен" Then
        ky = Cells(i, 2).Value
        it = Cells(i, 1).Value & "|" & Cells(i, 3).Value
        If dic.exists(ky) Then dic.Item(ky) = it Else dic.Add ky, it
    End If
Next
On Error Resume Next
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    If Cells(i, 3).Value = "Согласован" Or Cells(i, 3).Value = "Не требует согласования" Then
        ky = Cells(i, 2).Value
        s = Split(dic.Item(ky), "|")
        dic.Item(ky) = s(LBound(s)) & "|" & Cells(i, 1).Value
    End If
Next
i = 2
For Each ky In dic.keys
    s = Split(dic.Item(ky), "|")
    Range("G" & i) = ky
    Range("H" & i) = s(LBound(s))
    Range("I" & i) = s(UBound(s))
    Range("F" & i) = Mid(ky, 18, 16)
    i = i + 1
Next

    Application.ScreenUpdating = True 'включаем обновление экрана
    Application.Calculation = xlCalculationAutomatic 'включаем автоматический пересчёт формул после каждого действия с листом
    Application.EnableEvents = True 'включаем отслеживание событий
         
End Sub