Sub MergeUniqueData()

  Dim Blanks As Range
  Dim Data As Variant
  Dim DSO As Object
  Dim I As Long
  Dim Item As Variant
  Dim Key As Variant
  Dim Rng As Range
  Dim RngEnd As Range
  
    StartTime = Timer
    
    Set Rng = Worksheets("Sheet1").Range("A2")
    Set RngEnd = Rng.Parent.Cells(Rows.Count, Rng.Column).End(xlUp)
    Set Rng = IIf(RngEnd.Row < Rng.Row, Rng, Rng.Parent.Range(Rng, RngEnd))
    
      Application.ScreenUpdating = False
      
      Set DSO = CreateObject("Scripting.Dictionary")
      DSO.CompareMode = vbTextCompare
    
        Data = Rng.Resize(ColumnSize:=2).Value
        For I = 1 To UBound(Data, 1)
          Key = Trim(Data(I, 1))
          If Key <> "" Then
             Item = Data(I, 2)
             If Not DSO.Exists(Key) Then
                DSO.Add Key, I
             Else
                Data(DSO(Key), 2) = Data(DSO(Key), 2) + Item
                Data(I, 1) = ""
             End If
          End If
        Next I
        Rng.Value = Data
      
      On Error Resume Next
        Set Blanks = Rng.SpecialCells(xlCellTypeBlanks)
        If Err = 0 Then Blanks.EntireRow.Delete
      Err.Clear
      On Error GoTo 0
      
      Application.ScreenUpdating = True
      
    Set DSO = Nothing
    
    EndTime = Timer
    TotalTime = EndTime - StartTime
    '332.2813
     
End Sub

Sub FindCatOtherSheet()

Dim rFound As Range



    On Error Resume Next

    With Sheet1

        Set rFound = .Columns(1).Find(What:="Cat", After:=.Cells(1, 1), LookIn:=xlValues, LookAt:= _

            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _

            , SearchFormat:=False)

    On Error GoTo 0

        If Not rFound Is Nothing Then Application.Goto rFound, True

    End With
End Sub

Example

This example finds all cells in the range A1:A500 on worksheet one that contain the value 2 and changes it to 5.

With Worksheets(1).Range("a1:a500")
    Set c = .Find(2, lookin:=xlValues)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
            c.Value = 5
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With

Option Explicit
Sub ptest()
    Dim lRows As Long
    Application.ScreenUpdating = False
    With Sheet1.UsedRange
        lRows = .Rows.Count
    .Columns(2).Insert
    .Columns(2).FormulaR1C1 = "= SUMIF(R2C[-1]:R" & lRows & "C[-1],RC[-1],R2C[1]:R" & lRows & "C[1])"
    .Columns(2).Value = .Columns(2).Value
    .Resize(, 2).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Resize(, 2), copytorange:=Range("E1"), unique:=True
   .Columns(2).Delete
    End With
End Sub

 with Activesheet.used range

Public Sub findx()

Const StartRow = 2
Dim c, firstAddress, iR As Long, eR As Long, Q, Sh0 As Worksheet

Set Sh0 = Application.ActiveSheet

eR = Sh0.Range("A" & Rows.Count).End(xlUp).Row
Dim aCo() As Byte: ReDim aCo(eR) As Byte: For iR = 0 To eR: aCo(iR) = 0: Next

For iR = StartRow To eR
    If Sh0.Cells(iR, "A").Value2 = "" Then
        aCo(iR) = 2
    Else
        If aCo(iR) = 0 Then
            
            firstAddress = Sh0.Cells(iR, "A").Address
            Q = Sh0.Cells(iR, "A").Offset(, 1).Value2
            
            With Sh0.Range("a" & iR & ":a" & eR)
                Set c = .Find(Sh0.Cells(iR, "A").Value2, LookIn:=xlValues, LookAt:=xlWhole)
                Do While Not c Is Nothing And c.Address <> firstAddress
                    aCo(c.Row) = 1
                    If Q = c.Offset(, 1).Value2 Then aCo(c.Row) = 2
                    Set c = .FindNext(c)
                Loop
            End With
        End If
    End If
Next iR
For iR = eR To StartRow Step -1
   If aCo(iR) = 2 Then Sh0.Rows(iR).Delete
Next iR

End Sub