Veri parçala ve sırala

[SUHAOZBEK]

Hocam Merhaba,
Ekte bulunan çalışma kitabında Hücrede bulunan ad ve soyad ları önce harf harf parçalayıp sonrasında ise A dan Z ye sıralama işlemi yapmak istiyorum. Yardımlarınız ricasıyla.
İyi çalışmalar.

 

[YUSUF44]

Aşağıdaki kodları parçalamak için kullanabilirsiniz:

Sub parçala()
son = Cells(Rows.Count, "A").End(3).Row
For i = 1 To son
    For j = 1 To Len(Cells(i, "A"))
        yeni = WorksheetFunction.Max(3, Cells(i, Columns.Count).End(xlToLeft).Column + 1)
        Cells(i, yeni) = Mid(Replace(Cells(i, "A"), " ", ""), j, 1)
    Next
Next
End Sub

A'dan Z'ye sıralama işini anlamadım, isimleri oluşturan harfler kendi içinde mi sıralanacak, her sütun ayrı ayrı mı sıralanacak, yoksa tüm tablo mu sıralanacak?

 

[SUHAOZBEK]

Evet hocam isimleri oluşturan harfler kendi içinde A dan Z ye sıralanacak.
Teşekkür ederim.

 

[vardar07]

Yusuf44 arkadaşın koduna makro kaydet ile ekleme yapılmıştır.

Sub parçala()
Dim s1 As Worksheet
Set s1 = Sheets("Sayfa1")
syf = "Sayfa1"
Application.ScreenUpdating = False
son = s1.Cells(Rows.Count, "A").End(3).Row
For i = 1 To son
    For j = 1 To Len(s1.Cells(i, "A"))
        yeni = WorksheetFunction.Max(3, s1.Cells(i, Columns.Count).End(xlToLeft).Column + 1)
        s1.Cells(i, yeni) = Mid(Replace(s1.Cells(i, "A"), " ", ""), j, 1)
    Next j
 sut = s1.Range("c" & i).End(2).Column
b = Cells(i, sut).Address
s1.Range("C" & i & ":" & b).Select
    Selection.Copy
    s1.Range("AF1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Application.CutCopyMode = False
    ActiveWorkbook.Worksheets(syf).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(syf).Sort.SortFields.Add Key:=s1.Range("AF1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets(syf).Sort
        .SetRange s1.Range("AF1:AF" & Rows.Count)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Selection.Copy
    s1.Range("C" & i).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Application.CutCopyMode = False
    s1.Range("AF1:AF" & Rows.Count).Clear
    Next i
Application.ScreenUpdating = True
End Sub

 

[YUSUF44]

Aşağıdaki gibi düzenledim:

Sub parçalasırala()
son = Cells(Rows.Count, "A").End(3).Row
For i = 1 To son
        yeni = 3
    For j = 1 To Len(Replace(Cells(i, "A"), " ", ""))
        Cells(i, yeni) = Mid(Replace(Cells(i, "A"), " ", ""), j, 1)
        yeni = yeni + 1
    Next
        Range(Cells(i, "C"), Cells(i, "C").End(xlToRight)).Select
        ActiveSheet.Sort.SortFields.Clear
        ActiveSheet.Sort.SortFields.Add Key:=Range(Cells(i, "C"), Cells(i, "C").End(xlToRight)), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ActiveSheet.Sort
            .SetRange Range(Cells(i, "C"), Cells(i, "C").End(xlToRight))
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlLeftToRight
            .SortMethod = xlPinYin
            .Apply
        End With
Next
End Sub

 

[SUHAOZBEK]

Çok teşekkür ederim.
Emeğinize sağlık.
İyi çalşmalar