Excel VBA Optimize Cycle

As long as you've entered the VBA environment for a solution, there seems little point in not continuing that avenue toward the best route possible. The following uses a pair of Scripting.Dictionaries to build two sets of data from the original matrix in Sheet1. In addition to the main sub procedure, there are two short 'helper' functions that breach the 65536 barrier that Application.Index and Application.Transpose suffer from. These are necessary to peel out a row from a large two-dimensioned array and flip the orientation of the results while simultaneously splitting the stored records.

Sub Keep_Highest_BC()
    Dim d As Long, dHIGHs As Object, dDUPEs As Object
    Dim v As Long, vTMPs() As Variant, iCOLs As Long

    Debug.Print Timer
    '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)
            vTMPs = .Value2
        End With
    End With

    For v = LBound(vTMPs, 1) To UBound(vTMPs, 1)
        If dHIGHs.exists(vTMPs(v, 2)) Then
            If CDbl(Split(dHIGHs.Item(vTMPs(v, 2)), ChrW(8203))(2)) < vTMPs(v, 3) Then
                dDUPEs.Add Key:=vTMPs(v, 2) & v, Item:=dHIGHs.Item(vTMPs(v, 2))
                dHIGHs.Item(vTMPs(v, 2)) = joinAtoAQ(vTMPs, v)
            Else
                dDUPEs.Add Key:=vTMPs(v, 2) & v, Item:=joinAtoAQ(vTMPs, v)
            End If
        Else
            dHIGHs.Add Key:=vTMPs(v, 2), Item:=joinAtoAQ(vTMPs, v)
        End If
    Next v

    With Worksheets("Sheet1")
        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")
        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

bm_Safe_Exit:
    dHIGHs.RemoveAll: Set dHIGHs = Nothing
    dDUPEs.RemoveAll: Set dDUPEs = Nothing

    Debug.Print Timer
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

Once the two dictionaries have been filled with maximum values and duplicate lesser values, the arrays are returned to the two worksheets en masse and subsequently split back into the 43 columns. One final effort is made to restore the original formatting from Sheet1 into Sheet2's data area.

I tested this on 75,000 rows of columns A through column AQ containing random sample data first with predominantly duplicate values in column B and then with roughly half duplicate values in column B. The first single pass was processed in 13.19 seconds; the second in 14.22. While your own results will depend on the machine you are running it on, I would expect a significant improvement over your original code. Post your own timed results (start and stop in seconds within the VBE's Immediate window, Ctrl+G) into the comments if you can.