"*" a rağmen sıralama (gerçekten önemli)

[BeRDeN]

arkadaşlar daha önce sordum ama cevap alamadım bir türlü. ve işim için çok önem arz ediyor.
resimdeki gibi bir dosyam var ve göreceğiniz üzere bazı hücrelerin başında "*" (yıldız işareti) var.
şimdi alfabetik olarak sıralamam lazım ancak excel baştaki yıldız olanları öne getiriyor sonradan diğer harflere geçiyor.
acaba yıldız yokmuş gibi sıralayabilir miyiz?

(üzerinde uygulayabilecek arkadaşlar için dosyayıda ekliyorum)

http://rapidshare.com/files/307482734/ISPARTA_TKF_-_Kopya.rar.html


edit; dosyayı 2003 ve rarlı yaptım

 

[Orion1]

Dosyayı 2003 formatında yüklerseniz,2007 olmayan arkadaşlarda yardım edebilirler.

 

[Skorpiyon]

Sayın BeRDeN,

Sanırım böyle bir şey istiyorsunuz. Ama Evren hocamın dediği gibi dosyanızı Office 2003 versiyonuyla yüklerseniz, üzerinde halledebiliriz. Veya siz kodları alıp kendinize uyarlayabilirsiniz.

 

[BeRDeN]

hayır böyle istemiyorum. yıldızlar yine kalacak ama yıldız yokmuş gibi sıralayacak.
off

 

[Orion1]

hayır böyle istemiyorum. yıldızlar yine kalacak ama yıldız yokmuş gibi sıralayacak.
off

Ben yapıcam ama dosyayı rapidden indiremiyorum.Freeusere basıyorum ama indirmiyor.
Dosyayı rarla sıkıştırıp eklerseniz daha iyi olur.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub SIRALA()
    Dim X As Long
    
    Application.ScreenUpdating = False
        
    For X = 1 To Range("B1048576").End(3).Row
        If Left(Cells(X, 2), 1) = "*" Then
        Cells(X, 2) = Mid(Cells(X, 2), 2, Len(Cells(X, 2)) - 1)
        Cells(X, 3) = "*"
        End If
    Next
    
    Columns("A:C").Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    
    For X = 1 To Range("B1048576").End(3).Row
        If Cells(X, 3) = "*" Then
        Cells(X, 2) = Cells(X, 3) & Cells(X, 2)
        Cells(X, 3).Clear
        End If
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[uzmanamele]

merhaba

ek dosya işinizi görür mü?

Sub yıldızı_sona_al()
Dim metin As String
For i = 2 To Cells(65536, 2).End(3).Row
If Left(Cells(i, 2), 1) = "*" Then
metin = Mid(Cells(i, 2), 2, Len(Cells(i, 2)) - 1) & "*"
Else
metin = Cells(i, 2)
End If
Cells(i, 4) = metin
Cells(i, 5) = Cells(i, 3)
Next
End Sub

Sub sırala()
    Range("D2:E65536").Select
    Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
End Sub

Sub yıldızı_basa_al()
Dim metin As String
For j = 2 To Cells(65536, 4).End(3).Row
If Right(Cells(j, 4), 1) = "*" Then
metin = "*" & Left(Cells(j, 4), Len(Cells(j, 4)) - 1)
Else
metin = Cells(j, 4)
End If
Cells(j, 4) = metin
Next
End Sub

Sub düzenle()
Call yıldızı_sona_al
Call sırala
Call yıldızı_basa_al
For k = 2 To Cells(65536, 4).End(3).Row
Cells(k, 2) = Cells(k, 4)
Cells(k, 3) = Cells(k, 5)
Next k
    Columns("D:E").Select
    Selection.ClearContents
End Sub