Başlangıç harfi benzersiz olanları sıralama

[Erdem Akdemir]

Ekteki tabloda , başlangıç harfi farklı olanlardan bir sıralama yapmak istiyorum

 

[Erdem Akdemir]

soruyu güncelledim

 

[baydeniro]

Sayın Kuvari. İlgili tabloyu A2 hücresindenden başlayacak şekilde yeniden yapıştırın. Aşağıdaki kodu modüle kopyalayıp, makro tuşuna bağlayın.

Sub SIRALAT()

Sheets("Sayfa1").Select
Range("E1").Select
ActiveCell.FormulaR1C1 = "=""$B2:$B""&COUNTA(C[-4])+1"
Range("B2").Select
ActiveCell.FormulaR1C1 = _
"=IF(COUNTIF(R1C2:R[-1]C,LEFT(RC1,1))>=1,""."",LEFT(RC1,1))"
Range("B2").Select
Selection.Copy
Range([E1]).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("B:B").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range([E1]).Select
Selection.Copy
Range("E2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Sort Key1:=Range("E2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

Range("E1").Select
Selection.ClearContents
Columns("E:E").Select
Selection.Replace What:=".", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("E2:E60000").Select
Selection.Sort Key1:=Range("E2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("A1").Select

End Sub