Проблемы с повторами

Sub StrangeProblem()
   Dim mARR(), i&
   mARR = Range("A1", Cells(Rows.Count, "a").End(xlUp)).Value
   ReDim Preserve mARR(1 To UBound(mARR, 1), 1 To 2)
      For i = LBound(mARR, 1) To UBound(mARR, 1)
         mARR(i, 2) = mARR(i, 1)
         mARR(i, 1) = Application.Trim(Split(mARR(i, 1))(0))
      Next 'i
   [d1].Resize(UBound(mARR, 1), UBound(mARR, 2)).Value = mARR
   [d1].CurrentRegion.RemoveDuplicates 1, xlNo
   Columns("d:d").Delete
End Sub

Sub v2StrangeProblem()
Dim mARR(), i&
   mARR = Range("A1", Cells(Rows.Count, "a").End(xlUp)).Value
   With CreateObject("scripting.dictionary")
      For i = LBound(mARR) To UBound(mARR)
         mstr = Split(Application.Trim(mARR(i, 1)), Space(1))(0)
         If Not .exists(Split(Application.Trim(mARR(i, 1)), Space(1))(0)) Then
            .Add Split(Application.Trim(mARR(i, 1)), Space(1))(0), mARR(i, 1)
         End If
      Next 'i
      mARR = .items
   End With
   Range("A1", Cells(Rows.Count, "a").End(xlUp)).ClearContents
   [a1].Resize(UBound(mARR) + 1, 1).Value = Application.Transpose(mARR)
End Sub