Sub es()
Dim WS As Worksheet, m As Object, c As Range
Application.ScreenUpdating = 0
For Each WS In Sheets
If WS.Name <> "DAMES" Then
With WS
.Range("b2:b11").Copy Sheets("DAMES").Cells(Rows.Count, 1).End(3)(2)
End With
End If
Next WS
With Sheets("DAMES")
Set m = CreateObject("Scripting.Dictionary")
For Each c In .Range("a2", .Cells(Rows.Count, "a").End(3))
m(c.Value) = ""
Next c
.Range("a2:a200").ClearContents
.[a2].Resize(m.Count, 1) = Application.Transpose(m.keys)
.[a2:a200].Sort Key1:=.[a2], Order1:=xlAscending, Header:=xlGuess
End With
End Sub