Выделение одинаковых значений

[godkiller07]

Сообщение от Казанский

Пробуйте. Работает с активным листом, формирует на другом листе.

Sub bb()
Dim i&, a As Range, d As Range
Application.ScreenUpdating = False
ActiveSheet.Copy after:=ActiveSheet
[C:C].Insert
Range("A1", Cells(Rows.Count, "A").End(xlUp)).Offset(, 2) = "A"
With Range("D1", Cells(Rows.Count, "D").End(xlUp))
  .Offset(, 2).Value = "C"
  .Resize(, 3).Cut Cells(Rows.Count, "A").End(xlUp).Offset(1)
End With
[A1].Sort [A1], xlAscending, Header:=xlNo
i = 1
Set a = Range("C:C").Find("A")
Set a = Range("C:C").ColumnDifferences(a)
For Each a In a
  i = a.Row
  If i > 1 Then
    If Cells(i, 1) = Cells(i - 1, 1) Then
      Cells(i, 1).Resize(, 3).Cut Cells(i - 1, 4)
      If d Is Nothing Then Set d = Cells(i, 1) Else Set d = Union(d, Cells(i, 1))
    Else
      Cells(i, 1).Resize(, 3).Cut Cells(i, 4)
    End If
  Else
    Cells(i, 1).Resize(, 3).Cut Cells(i, 4)
  End If
Next
Range("C:C,F:F").Delete
d.EntireRow.Delete
Application.ScreenUpdating = True
End Sub

Всё отлично, а можно сделать так что бы было например:

[Казанский]

А сразу нельзя было выложить реальный пример, с тремя столбцами, с заголовком?
Больше переделывать не буду!

Sub bb()
Dim i&, a As Range, d As Range
Application.ScreenUpdating = False
ActiveSheet.Copy after:=ActiveSheet
Range("D:D").ClearContents
Range("A2", Cells(Rows.Count, "A").End(xlUp)).Offset(, 3) = "A"
With Range("E2", Cells(Rows.Count, "E").End(xlUp))
  .Offset(, 3).Value = "C"
  .Resize(, 4).Cut Cells(Rows.Count, "A").End(xlUp).Offset(1)
End With
[A1].Sort [B1], xlAscending, Header:=xlYes
i = 2
Set a = Range("D:D").Find("A")
Set a = Range("D:D").ColumnDifferences(a)
For Each a In a
  i = a.Row
  If i > 1 Then
    If Cells(i, 1) = Cells(i - 1, 1) Then
      Cells(i, 1).Resize(, 3).Cut Cells(i - 1, 5)
      If d Is Nothing Then Set d = Cells(i, 1) Else Set d = Union(d, Cells(i, 1))
    Else
      Cells(i, 1).Resize(, 3).Cut Cells(i, 5)
    End If
  End If
Next
Range("D:D").ClearContents
If Not d Is Nothing Then d.EntireRow.Delete
Application.ScreenUpdating = True
End Sub