önünde harf olan rakamları kod ile sıralatmak

[edacan19]

arkadaşlar siteden seçili alanlardaki rakamları sıralayan bir kod buldum fakat önünde harf olanlarda sıralamayı yapmıyor yardımcı olabilirseniz sevinirim.

 

[snx111]

önünde harf olan rakamları kod ile sıralatmak yasaktır !

 

[Necdet]

Merhaba,

Aşağıdaki kodları deneyiniz.

Rakam önündeki harflerin adedi belli ise kodlar hem daha kısalır hemde daha hızlı çalışır.

önünde harf olan rakamları kod ile sıralatmak yasaktır !

Neden böyle bir yanıt yazma gereğini duydunuz anlayamadım.

Sub SeciliAlanSIRALA()
 
    Dim Adres   As String
    Dim i       As Long
    Dim j       As Integer
    Dim Hucre   As Range
 
    If Selection.Count = 1 Then
        MsgBox "Birden Fazla Hücre Seçiniz...."
        Exit Sub
    End If
 
    Adres = Selection.Cells(1, 1).Address
 
    For Each Hucre In Selection
        i = i + 1
        Cells(i, Columns.Count - 2) = Hucre.Value
        If IsNumeric(Hucre.Value) Then
            Cells(i, Columns.Count - 1) = Hucre.Value
            Cells(i, Columns.Count) = Hucre.Value
        Else
            j = 0
            Do
                j = j + 1
            Loop While IsNumeric(Mid(Hucre.Value, j, 1)) Or j = Len(Hucre.Value)
 
            Cells(i, Columns.Count - 1) = Left(Hucre.Value, j)
            Cells(i, Columns.Count) = Right(Hucre.Value, Len(Hucre) - j)
        End If
    Next Hucre
 
    Range(Cells(1, Columns.Count - 2), Cells(i, Columns.Count)).Sort Key1:=Cells(1, Columns.Count - 1), Key2:=Cells(1, Columns.Count)
    Range(Cells(1, Columns.Count - 2), Cells(i, Columns.Count - 2)).Copy Range(Adres)
    Range(Cells(1, Columns.Count - 2), Cells(i, Columns.Count)).Clear
 
End Sub

 

[snx111]

Konu up olsun diye hocam Sabah yazıldı konu cvp veren olmadı ; Biraz uğraştım yapamayınca üstadların Görmesini istedim işe yaramışa benziyor.. Saygılarımı sunarım

 

[edacan19]

çok teşekkür ediyorum sırama kesinlikle tam istediğim gibi yalnız seçtiğim alanın içine sıralamayıp alta atıyor bu nedenlede yazdırma alanından çıkıyor buna bir çözüm bulabilirmiyiz.

 

[edacan19]

tekrar inceledim bir sutun içindekileri seçersek hiçbirsorun yok birden fazla sutun içindekileri seçersek 1. sutun hariç diğer sutundakileri sıralayarak 1. sutuna taşıyor. seçtiğim alanlardaki sayıları aynı alanlara sıralaması gerekiyor.

 

[Necdet]

tekrar inceledim bir sutun içindekileri seçersek hiçbirsorun yok birden fazla sutun içindekileri seçersek 1. sutun hariç diğer sutundakileri sıralayarak 1. sutuna taşıyor. seçtiğim alanlardaki sayıları aynı alanlara sıralaması gerekiyor.

Merhaba,

Tek sütun seçileceğini varsayarak yapmıştım.

Örnek dosya eklerseniz birden fazla sütun için üzerinde çalışmaya çalışırım. Becerebilirsek ne ala

 

[edacan19]

kusura bakmayın örneği unuttum şimdi ekliyorum. 10000 tane veriyi sıralamam gerekiyor yoksa işim çok zorlaşacak rakamlar kitapların demirbaşları bazıları 1 2 3... diye gidiyor bazıları c1 c2 c3 diye gidiyor.

 

[Necdet]

Merhaba,

Sorunu anlar gibi oldum ama şu an ilgilenemeyeceğim, fırsat buldu mu yapmaya çalışacağım.

Malum işyeri koşulları

 

[Necdet]

Merhaba,

Aşağıdaki kodları dener misiniz?

Sub SeciliAlanSIRALA()
 
    Dim Adres   As String
    Dim i       As Long
    Dim j       As Integer
    Dim Adt     As Long
    Dim Sat     As Long
    Dim Kol     As Integer
    Dim Hucre   As Range
 
    If Selection.Count = 1 Then
        MsgBox "Birden Fazla Hücre Seçiniz...."
        Exit Sub
    End If
 
    Application.ScreenUpdating = False
    
    Adres = Selection.Cells(1, 1).Address
    Sat = Range(Adres).Row
    Kol = Range(Adres).Column
    
    Adt = Selection.Rows.Count
    
    For Each Hucre In Selection
        i = i + 1
        Cells(i, Columns.Count - 2) = Hucre.Value
        If IsNumeric(Hucre.Value) Then
            Cells(i, Columns.Count - 1) = Hucre.Value
            Cells(i, Columns.Count) = Hucre.Value
        Else
            j = 0
            Do
                j = j + 1
            Loop While IsNumeric(Mid(Hucre.Value, j, 1)) Or j = Len(Hucre.Value)
 
            Cells(i, Columns.Count - 1) = Left(Hucre.Value, j)
            Cells(i, Columns.Count) = Right(Hucre.Value, Len(Hucre) - j)
        End If
    Next Hucre
 
    Selection.ClearContents
    
    Range(Cells(1, Columns.Count - 2), Cells(i, Columns.Count)).Sort Key1:=Cells(1, Columns.Count - 1), Key2:=Cells(1, Columns.Count)
 
    For i = 1 To Cells(Rows.Count, Columns.Count - 2).End(3).Row Step Adt
        Range(Cells(i, Columns.Count - 2), Cells(i + Adt - 1, Columns.Count - 2)).Copy Cells(Sat, Kol)
        Kol = Kol + 1
    Next i
    Range(Cells(1, Columns.Count - 2), Cells(i, Columns.Count)).Clear
 
    Application.ScreenUpdating = True
    
    MsgBox "SIRALAMA BİTMİŞTİR....", vbInformation, "N. YEŞERTENER --> [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
End Sub

 

[edacan19]

çok teşekkür ediyorum tam istediğim gibi olmuş ellerinize sağlık

 

[Necdet]

çok teşekkür ediyorum tam istediğim gibi olmuş ellerinize sağlık

Güle güle kullanınız hemşehrim