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