tek hücrede farklı renkle yazmak

[tiretwien]

merhaba arkadaşlar,
asagıdaki linkteki tablomda yardımınıza ihtiyacım var.
a ve b sutunlarında sayılarım var
ben C sütüna bu sayıları tek hücrede küçükten büyüğe sıralamak istiyorum ama sıra olurken ahmet kırmızı renk ali mor renk olmasını istiyorum

böyle bir işlem yapılabilir mi ?

Başlıksız e-tablo

Sayfa1 ahmet,ali,istedigim sonuç 22 90,45 75,22 45 75 90 30 33 41 72 77,30 33 41 72 77 66,27 45,3 72,27 45,3 66 72 65 71,65 71 31 90,15,15 31 90 90,30,30 90 80,80 35,35 6 54,26,6 26 54 78 83,47 85 88,47 78 83 85 88 3 7,2 44,2 3 7 44 17 87,43 60,17 43 60 87

docs.google.com

 

[Korhan Ayhan]

C sütununda görmek istediğiniz sonucu da ekleyip dosyanızı günceller misiniz?

 

[tiretwien]

@Korhan Ayhan merhaba dosyayı güncelledim.
yardımınızı rica ederim
a ve b deki sayılar birleşecek kucukten buyuge sıralanacak. ahmet in rengi kırmızı ali mor olacak. manuel beni baya ugrastırıyor

 

[Seyit Tiken]

Sütunlar şeklinde yaparsanız olmuyor mu?

 

[Korhan Ayhan]

Sayılarda tekrar etme durumu var mı?

 

[tiretwien]

@Seyit Tiken tek hucrede toplansa iyi olur ama kucukten buyuge ve renk ayriminin olmasi benim icin onemlisi
@Korhan Ayhan sayilarda tekrar durumu yok

Tesekkur ederim

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Sirala_Renklendir()
    Dim Son As Long, Metin As Variant, X As Long, Veri As Variant, Y As Long, Bul As Integer, Renk As Long
   
    Son = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   
    Range("D:D").Clear
    Range("D:D").HorizontalAlignment = xlCenter
   
    With CreateObject("System.Collections.ArrayList")
        For X = 2 To Son
            If Cells(X, 1).Text <> "" And Cells(X, 2).Text <> "" Then
                Metin = Cells(X, 1).Text & " " & Cells(X, 2).Text
            ElseIf Cells(X, 1).Text <> "" Then
                Metin = Cells(X, 1).Text
            Else
                Metin = Cells(X, 2).Text
            End If
           
            Veri = Split(WorksheetFunction.Trim(Metin), " ")
           
            For Y = LBound(Veri) To UBound(Veri)
                .Add Veri(Y) * 1
            Next
           
            .Sort
            Cells(X, "D") = " " & Join(.ToArray, " ")
            .Clear
           
            Renk = 255
           
            For Each Metin In Range("A" & X & ":B" & X)
                If Metin <> "" Then
                    Veri = Split(Metin, " ")
                    For Y = LBound(Veri) To UBound(Veri)
                        Bul = InStr(1, Cells(X, "D"), " " & Veri(Y))
                        Cells(X, "D").Characters(Start:=Bul, Length:=Len(" " & Veri(Y))).Font.Color = Renk
                    Next
                End If
                Renk = -65383
            Next
        Next
    End With
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[tiretwien]

@Korhan Ayhan hocam cok teşekkür ederim mükemmel olmuş. tam istedigim gibi
ancak tek haneli sayıları doğru sıralamıyor.
şöyle bir test yaptım
mesela 2 yerine 02 yazınca 3 yerine 03.....9kadar yazınca küçükten büyüğe sıralıyor. bunu düzeltme şansı var mıdır

 

[Korhan Ayhan]

Kodu revize ettim. Tekrar deneyiniz.

 

[tiretwien]

@Korhan Ayhan hocam run time error 13 type mismatch hatası verdi

 

[Korhan Ayhan]

Uyguladığınız dosyayı paylaşırsanız inceleme fırsatımız olur.

 

[tiretwien]

@Korhan Ayhan buyrun

İndir iş adetleri

Dosyayı indir iş adetleri

dosya.co

 

[Korhan Ayhan]

Rakamların arasında fazla boşluklardan dolayı sorun oluşmuş.

Koda küçük bir ekleme yaptım. Tekrar deneyiniz.

 

[tiretwien]

@Korhan Ayhan hocam cok teşekkür ederim bu sefer oldu. elinize bilginize sağlık