Copier/ coller plusieurs plages identiques à la suite dans une nouvelle feuille

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