Disponibilize parte desse arquivo para testes

coloque seu projeto para nós olharmos o que está errado ...
mas parece que é algo com loop.

Pelo que eu entendi do problema dá a impressão que esse código é meio "enroscado". Duas rotinas para fazer algo que pode ser feito em uma só?

Desculpem não ter respondido mais cedo, no entanto já consegui resolver o problema com um código diferente.

Sub Keep_Highest_BC() ' Retira repetidos para outra tabela -> codigo das ot.
        
    Debug.Print Time
    Application.ScreenUpdating = False
    
    Dim d As Long, dHIGHs As Object, dDUPEs As Object
    Dim v As Long, vTMPs() As Variant, iCOLs As Long, Tam As Long

    'On Error GoTo bm_Safe_Exit
    Set dHIGHs = CreateObject("Scripting.Dictionary")
    Set dDUPEs = CreateObject("Scripting.Dictionary")

    With Worksheets("Sheet1")
        iCOLs = .Columns("AQ").Column
        .Cells(1, 1).Resize(2, iCOLs).Copy _
          Destination:=Worksheets("Sheet2").Cells(1, 1)
        With .Cells(2, 1).Resize(.Cells(Rows.Count, 2).End(xlUp).Row - 1, iCOLs) ' Vai guardar a info toda da tabela em vTMPs
            vTMPs = .Value2
        End With
    End With

    For v = LBound(vTMPs, 1) To UBound(vTMPs, 1)
         If vTMPs(v, 42) <> "" And vTMPs(v, 42) <> "#MULTIVALOR" And vTMPs(v, 40) <> "#MULTIVALOR" And vTMPs(v, 39) <> "#MULTIVALOR" Then
            If dHIGHs.exists(vTMPs(v, 2)) Then ' Vais verificar se o valor já existe
                If CDbl(Split(dHIGHs.Item(vTMPs(v, 2)), ChrW(8203))(2)) < vTMPs(v, 4) Then ' Para cada valor que este estiver em dHIGHs vai ver qual data fim mais recente
                    dDUPEs.Add Key:=vTMPs(v, 2) & v, Item:=dHIGHs.Item(vTMPs(v, 2)) 'Caso a linha já guardada tenha data menor vai copia-la para dDUPEs
                    dHIGHs.Item(vTMPs(v, 2)) = joinAtoAQ(vTMPs, v)                  ' E guardar a nova linha na dHIGHs
                Else
                    dDUPEs.Add Key:=vTMPs(v, 2) & v, Item:=joinAtoAQ(vTMPs, v) 'Caso a nova linha tenha data menor guarda logo em dDUPEs
                End If
            Else
                dHIGHs.Add Key:=vTMPs(v, 2), Item:=joinAtoAQ(vTMPs, v) 'Caso não exista em dHIGHs guarda logo lá, pois ainda não esta repetido
            End If
        
        Else
            dDUPEs.Add Key:=vTMPs(v, 2) & v, Item:=joinAtoAQ(vTMPs, v) ' Caso nao tenha info nas ultimas linhas é considerado repetido
        End If
    Next v

    With Worksheets("Sheet1") 'Vai apagar a tabela original, colocando uma tabela que contenha apenas os valores unicos
        With .Cells(2, 1).Resize(.Cells(Rows.Count, 2).End(xlUp).Row - 1, iCOLs)
            .ClearContents
            With .Resize(dHIGHs.Count, iCOLs)
                .Value = transposeSplitLargeItemArray(dHIGHs.items)
            End With
        End With
    End With

    With Worksheets("Sheet2") ' vai criar a tabela com valores repetidos
        With .Cells(1, 1).CurrentRegion.Offset(1, 0)
            .ClearContents
            With .Resize(dDUPEs.Count, iCOLs)
                .Value = transposeSplitLargeItemArray(dDUPEs.items)
                .Rows(1).Copy
                .PasteSpecial Paste:=xlPasteFormats
                Application.CutCopyMode = False
            End With
        End With
    End With
    
    Tam = Worksheets("Sheet2").ColocaDatas2
    ColocaDatas (Tam)

bm_Safe_Exit:
    dHIGHs.RemoveAll: Set dHIGHs = Nothing
    dDUPEs.RemoveAll: Set dDUPEs = Nothing
    
Application.ScreenUpdating = False

    Debug.Print Time
End Sub

Function joinAtoAQ(vTMP As Variant, ndx As Long)
    Dim sTMP As String, v As Long

    For v = LBound(vTMP, 2) To UBound(vTMP, 2)
        sTMP = sTMP & vTMP(ndx, v) & ChrW(8203)
    Next v
    joinAtoAQ = Left$(sTMP, Len(sTMP) - 1)
End Function

Function transposeSplitLargeItemArray(vITMs As Variant)
    Dim v As Long, w As Long, vTMPs As Variant, vITM As Variant

    ReDim vTMPs(LBound(vITMs) To UBound(vITMs), LBound(vITMs) To UBound(Split(vITMs(LBound(vITMs)), ChrW(8203))))
    For v = LBound(vITMs) To UBound(vITMs)
        vITM = Split(vITMs(v), ChrW(8203))
        For w = LBound(vITM) To UBound(vITM)
            vTMPs(v, w) = vITM(w)
        Next w
    Next v

    transposeSplitLargeItemArray = vTMPs
End Function

Obrigado pela ajuda e peço uma vez mais não ter respondido mais cedo.