Sub dс()
Dim dic
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, 1).Value
        it = Cells(i, 2).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, 1).Value
        s = Split(dic.Item(ky), "|")
        dic.Item(ky) = s(LBound(s)) & "|" & Cells(i, 2).Value
    End If
Next
i = 2
For Each ky In dic.keys
    s = Split(dic.Item(ky), "|")
    Range("E" & i) = ky
    Range("F" & i) = s(LBound(s))
    Range("G" & i) = s(UBound(s))
    i = i + 1
Next
End Sub

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 

let
    Source = Excel.CurrentWorkbook(){[Name="Заказы"]}[Content],
    maker = Table.Group(Table.Sort(Source, {"Заказ", "Период"}), {"Заказ"}, {
        {"Дата отправки на согласование", (sub) =>
        let
            minInfo = Table.Min(Table.SelectRows(sub, each [Статус] = "На согласовании"), "Период"),
            maxInfo0 = Table.Max(sub, "Период")
        in
            if minInfo = null then maxInfo0[Статус] else minInfo[Период]
        },
        {"Дата согласования", (sub) =>
        let
            maxInfo1 = Table.Max(sub, "Период"),
            maxInfo2 = Table.Min(Table.SelectRows(sub, each List.Contains({"Согласован", "Не требует согласования"},[Статус])), "Период")
     
        in
              if maxInfo2 = null then maxInfo1[Статус] else maxInfo2[Период]
        }
    }, GroupKind.Local),
    #"Разделить столбец по разделителю" = Table.SplitColumn(maker, "Заказ", Splitter.SplitTextByDelimiter(" ", QuoteStyle.Csv), {"Заказ.1", "Заказ.2", "Заказ.3", "Заказ.4", "Заказ.5", "Заказ.6"}),
    #"Переименованные столбцы" = Table.RenameColumns(#"Разделить столбец по разделителю",{{"Заказ.5", "Заказ дата"}, {"Заказ.3", "Заказ"}}),
    #"Удаленные столбцы" = Table.RemoveColumns(#"Переименованные столбцы",{"Заказ.1", "Заказ.2", "Заказ.4", "Заказ.6"}),
    #"Переупорядоченные столбцы" = Table.ReorderColumns(#"Удаленные столбцы",{"Заказ", "Дата отправки на согласование", "Дата согласования", "Заказ дата"})
in
    #"Переупорядоченные столбцы"

Sub Order_Status()
Dim arr(), iArr(), arrNew()
Dim I&, iUB&, iKey
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
    
With ThisWorkbook.Worksheets("TDSheet")
    arr = .Range("A2:C" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
End With
On Error Resume Next
With CreateObject("Scripting.Dictionary")
    For I = 1 To UBound(arr)
        ReDim iArr(0 To 2, 0 To 0)
        iArr(0, 0) = Split(arr(I, 2))(2)
        iArr(1, 0) = arr(I, 1)
        iArr(2, 0) = arr(I, 3)
        .Add arr(I, 2), iArr
        If Err <> 0 Then
            iArr = .Item(arr(I, 2))
            iUB = UBound(iArr, 2) + 1
            ReDim Preserve iArr(0 To 2, 0 To iUB)
            iArr(1, iUB) = arr(I, 1)
            iArr(2, iUB) = arr(I, 3)
            .Item(arr(I, 2)) = iArr
            Err.Clear
        End If
    Next
    I = 1: ReDim arrNew(1 To .Count, 1 To 4)
    For Each iKey In .Keys
        iArr = .Item(iKey)
        arrNew(I, 1) = iArr(0, 0)
        arrNew(I, 2) = iKey
        Select Case iArr(2, UBound(iArr, 2))
            Case "Согласован", "Не требует согласования"
                arrNew(I, 3) = myDATE(iArr, "На согласовании")
                arrNew(I, 4) = myDATE(iArr, iArr(2, UBound(iArr, 2)))
            Case Else
                arrNew(I, 3) = IIf(myDATE(iArr, "На согласовании") = False, iArr(2, UBound(iArr, 2)), myDATE(iArr, "На согласовании"))
                arrNew(I, 4) = iArr(2, UBound(iArr, 2))
        End Select
        I = I + 1
    Next
End With
With ThisWorkbook.Worksheets("TDSheet")
' для ЗАМЕНЫ данных раскомментировать следующую строку и далее 'J2' заменить на 'E2'
'    .Range("E2:H" & .Cells(.Rows.Count, "E").End(xlUp).Row).ClearContents
    .Range("J2").Resize(UBound(arrNew), 4) = arrNew
End With

Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Private Function myDATE(myArr, iStr)
On Error Resume Next
With Application
    'все исходные Даты_как_текст преобразуются именно в ДАТЫ! Если не нужно - удалить Cdate()
    myDATE = CDate(myArr(1, .Match(iStr, .Index(myArr, 3, 0), 0) - 1))
End With
If Err <> 0 Then myDATE = False
End Function

Sub Order_Status()
Dim arr(), iArr(), arrNew()
Dim I&, iUB&, iKey
Dim iCol As New Collection
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
    
With ThisWorkbook.Worksheets("TDSheet")
    arr = .Range("A2:C" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
End With
On Error Resume Next
With iCol
    For I = 1 To UBound(arr)
        ReDim iArr(0 To 2, 0 To 0)
        iArr(0, 0) = arr(I, 1)
        iArr(1, 0) = arr(I, 2)
        iArr(2, 0) = arr(I, 3)
        .Add iArr, CStr(arr(I, 2))
        If Err <> 0 Then
            iArr = .Item(arr(I, 2))
            iUB = UBound(iArr, 2) + 1
            ReDim Preserve iArr(0 To 2, 0 To iUB)
            iArr(0, iUB) = arr(I, 1)
            iArr(2, iUB) = arr(I, 3)
            .Remove (arr(I, 2))
            .Add iArr, CStr(arr(I, 2))
            Err.Clear
        End If
    Next
    I = 1: ReDim arrNew(1 To .Count, 1 To 5): Erase iArr
    For Each iKey In iCol
        iStr = Split(iKey(1, 0))
        arrNew(I, 1) = iStr(2)
        arrNew(I, 2) = iKey(1, 0)
        Select Case iKey(2, UBound(iKey, 2))
            Case "Согласован", "Не требует согласования"
                arrNew(I, 3) = myDATE(iKey, "На согласовании")
                arrNew(I, 4) = myDATE(iKey, iKey(2, UBound(iKey, 2)))
            Case Else
                arrNew(I, 3) = IIf(myDATE(iKey, "На согласовании") = Empty, iKey(2, UBound(iKey, 2)), myDATE(iKey, "На согласовании"))
                arrNew(I, 4) = iKey(2, UBound(iKey, 2))
        End Select
        arrNew(I, 5) = iStr(4)
        I = I + 1
    Next
End With
With ThisWorkbook.Worksheets("TDSheet")
    .Range("E2:H" & .Cells(.Rows.Count, "E2").End(xlUp).Row).ClearContents
    .Range("E2").Resize(UBound(arrNew), 5) = arrNew
End With

Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Private Function myDATE(myArr, iStr)
For J = LBound(myArr, 2) To UBound(myArr, 2)
    If myArr(2, J) = iStr Then
        myDATE = CDate(myArr(0, J))
        Exit For
    End If
Next
End Function