sıralama

[blade_boy87]

Arkadaşlar kolay gelsin.
excel de A sütununda kalın yazıyla yazılmış verileri alt alta sıralamak istiyorum.
acaba mümkün müdür.

şimdiden teşekkür ederim

 

[Emir Hüseyin Çoban]

. . .

Sub kod_bir()

son = [a65536].End(3).Row
aa = 1
Columns("B:B").ClearContents

For i = 1 To son
If Cells(i, "a").Font.Bold = True And Cells(i, "a") <> "" Then
Cells(aa, "b") = Cells(i, "a")
aa = aa + 1
Else
End If
Next i

End Sub

. . .

 

[serqet]

mümkün.

Sub SortBold()
Application.ScreenUpdating = False
Dim Rng As Range
Dim Bld As Range
Set Rng = Range([A2], [A65536].End(xlUp))
Rng.Select
For Each Bld In Selection
Bld.Cells(1, 2) = Bld.Cells.Font.Bold
Next
Range(Rng, [B65536].End(xlUp)).Sort _
Key1:=Range("B2"), Order1:=xlDescending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Rng.Offset(, 1).ClearContents
Range("A1").Select
Application.ScreenUpdating = True
End Sub

 

[blade_boy87]

...

cevaplarınız için çok teşekkür ederim.
kodu yazdım ama kalın olarak yazılı olanları sıralama işlemi nasıl yapılacak acaba

 

[Murat OSMA]

Sayfaya bir buton ya da herhangi bir nesne (resim, şekil) ekleyin ve o resim üzerinde sağ tıklayın, sonra Makro Atayı seçin makronuzu seçip Tamam butonuna basın.

 

[blade_boy87]

ilginiz için teşekkür ederim
dediğiniz kodu yazdım fakat diğer sütunları etki etmiyor. sadece a sütununu sıraladı. diğer sütunları da aynı etkide sıralamasını yaptırabilirmiyiz

 

[blade_boy87]

yardımcı olabilir misiniz arkadaşlar

 

[Murat OSMA]

Dosyanızı ekleyip onun üzerinde bir anlatım yapmazsanız: çözüme ulaşmanız işte bu kadar uzun sürebiliyor...

 

[blade_boy87]

benim aslında yapmak istediğim tercih kılavuzunda fakülteleri ayırmak. fakülte isimleri zaten koyuyla yazılmış olanlar ona göre sıralayıp fakülteleri ayırmak.

 

[tahsinanarat]

Birleştirilmiş hücre olmaması lazım, birleştirilmiş hücreleri kaldırarak aşağıdaki kodu denermisiniz.

Sub asutunuboldsırala()
AZBUYUK
Columns("A:A").Insert Shift:=xlToRight
Cells(2, 1).Value = "0"
Application.ScreenUpdating = False
sat = 2
For i = 2 To [b65536].End(3).Row
If Cells(i, "b").Font.Bold = True Then
Cells(i, "a").Value = sat - 1
sat = sat + 1
End If
Next i
For i = 2 To [b65536].End(3).Row
If Cells(i, "b").Font.Bold = False Then
Cells(i, "a").Value = sat - 1
sat = sat + 1
End If
Next i
AZBUYUK
Columns("A:A").Delete Shift:=xlToLeft
Application.ScreenUpdating = True
Range("A1").Select
End Sub
Sub AZBUYUK()
AD = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A2:A65000")) + 1
RA = 2 & ":"
CA = RA & AD
Rows(CA).Select
ta = 1
YA = 2 & ":" & AD
Rows(YA).Sort Key1:=Cells(ta), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'MsgBox ("Sıralama Küçükden Büyüke yapıldı...")
End Sub

 

[blade_boy87]

ilginiz için teşekkür ederim ama kodu yazdığımda
Sub asutunuboldsırala()
AZBUYUK
hata veriyor.
birleştirilmiş hücreleri kaldırdım..

 

[tahsinanarat]

Kodlarınız aşağıda

aşağıdaki kodları denedim, herhangi bir hata yok. Siz saadece Makro1 i çalıştıracaksınız.

Sub Makro1()
AZBUYUK
Columns("A:A").Insert Shift:=xlToRight
Cells(2, 1).Value = "0"
Application.ScreenUpdating = False
sat = 2
For i = 2 To [b65536].End(3).Row
If Cells(i, "b").Font.Bold = True Then
Cells(i, "a").Value = sat - 1
sat = sat + 1
End If
Next i
For i = 2 To [b65536].End(3).Row
If Cells(i, "b").Font.Bold = False Then
Cells(i, "a").Value = sat - 1
sat = sat + 1
End If
Next i
AZBUYUK
Columns("A:A").Delete Shift:=xlToLeft
Application.ScreenUpdating = True
Range("A1").Select
End Sub
Sub AZBUYUK()
AD = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A2:A65000")) + 1
RA = 2 & ":"
CA = RA & AD
Rows(CA).Select
ta = 1
YA = 2 & ":" & AD
Rows(YA).Sort Key1:=Cells(ta), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'MsgBox ("Sıralama Küçükden Büyüke yapıldı...")
End Sub