1 KENT TOLK 4449346878
2 KENT TOLK 4446286088
3 KENT TOLK 4442080098
4 KENT TOLK 0008120884
5 KENT TOLK 9999883468

neden 4. satırdaki veri en üste değil?
sonradan fark ettim galiba hiç biri sıralı değil??

aşağıdaki kodu dener misiniz?

Sub VeriAlSirala()

    Dim ws As Worksheet

    Dim StrSay As Long, j As Integer

    Dim TmpDz As Variant, SonDz As Variant, xDz As Variant

        

    Set ws = ThisWorkbook.Worksheets("örnek")

  

  SonVeri = Split(ws.UsedRange.Address & ws.UsedRange.Address, "$")(4)

    

    xDz = ws.Range("A2:C" & SonVeri).Value2

    ReDim SonDz(1 To 1000000, 2)

    StrSay = 0

    

    For xStr = LBound(xDz) To UBound(xDz)

    TmpDgr = ""

    For Each itm In Split("," & xDz(xStr, 3), ",")

        If Len(Trim(itm) & "") = 10 Then If IsNumeric(itm) Then TmpDgr = TmpDgr & "," & itm

    Next itm

    TmpDz = Split(TmpDgr, ",")

        '________________________________________________________Sıralama

    

        ilk = LBound(TmpDz) + 1

        son = UBound(TmpDz)

        For i = ilk To son - 1

            For j = i + 1 To son

                If Val(TmpDz(i)) > Val(TmpDz(j)) Then

                    Temp = TmpDz(j)

                    TmpDz(j) = TmpDz(i)

                    TmpDz(i) = Temp

                End If

            Next j

        Next i

        '________________________________________________________

            For x = 1 To UBound(TmpDz)

                    StrSay = StrSay + 1

                    SonDz(StrSay, 0) = xDz(xStr, 1)

                    SonDz(StrSay, 1) = xDz(xStr, 2)

                    SonDz(StrSay, 2) = "'" & Format(TmpDz(x), "0000000000")

            Next x

    Next xStr



    ws.UsedRange.Offset(1).Cells.Clear

    ws.Range("A2").Resize(StrSay, 3) = SonDz



End Sub

sıralama olmadan

Sub VeriDuzenle()



Dim ws As Worksheet

Dim StrSay As Long, j As Integer

Dim TmpDz As Variant, SonDz As Variant, xDz As Variant

   

    Set ws = ThisWorkbook.Worksheets("örnek")

   SonVeri = Split(ws.UsedRange.Address & ws.UsedRange.Address, "$")(4)

       xDz = ws.Range("A2:C" & SonVeri).Value2

    

    ReDim SonDz(1 To 1000000, 2)

    StrSay = 0

    

    For xStr = LBound(xDz) To UBound(xDz)

        For Each itm In Split("," & xDz(xStr, 3), ",")

            If Len(Trim(itm) & "") = 10 Then

                If IsNumeric(itm) Then

                        StrSay = StrSay + 1

                        SonDz(StrSay, 0) = xDz(xStr, 1)

                        SonDz(StrSay, 1) = xDz(xStr, 2)

                        SonDz(StrSay, 2) = "'" & Format(Trim(itm), "0000000000")

                End If

            End If

        Next itm



    Next xStr



    ws.UsedRange.Offset(1).Cells.Clear

    ws.Range("A2").Resize(StrSay, 3) = SonDz

End Sub

Çok teşekkür ederim harika olmuş eline sağlık

rica ederim
iyi çalışmalar
kodlarda anlamadığınız yerleri araştırıp -anlayamadığınız yerde de - sormanız öğrenme sürecini hızlandıracaktır.