sayıya göre renge boyama

Katılım
21 Temmuz 2015
Mesajlar
20
Excel Vers. ve Dili
EXCEL 2013 PROFESIONAL PLUS
elimde 7 ve 8 sayılı rakamlar mevcut ,
ilk üç hanesi aynı olan rakamları başka renge boyasa ,
aynı seriyi bulmam kolaylaşacak.
şimdiden teşekkürler
 

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,254
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
Koşullu biçimlendirme işinize yarayacaktır.:cool:
 

aligunes

Altın Üye
Katılım
2 Mart 2005
Mesajlar
303
Excel Vers. ve Dili
Ofis 2016 TR 32 Bit
Koşullu Biçimlendirme>Renk Ölçekleri>Diğer Kurallar>Yalnızca derecelendirilen en üst veya en alt değerleri biçimlendir

derecelendirilen değeri ilk 3 yap renk desen ayarla tamam
 
Katılım
21 Temmuz 2015
Mesajlar
20
Excel Vers. ve Dili
EXCEL 2013 PROFESIONAL PLUS
yaptım ama olmuyor. birde siz bakar mısınız?
aşama aşama hepsini seçtim olmuyor :(
 

Ekli dosyalar

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,254
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
Kodda 3 yazan yeri 4 yapınız.:cool:
 

kulomer46

Altın Üye
Katılım
23 Mart 2007
Mesajlar
1,512
Excel Vers. ve Dili
Microsoft Office LTSC Professional Plus 2021 - Türkçe
çok teşekkür ederim. sizden bir ricam daha olacaktı. 3 değilde 4 rakama göre ayarlama yapabilir misiniz?
Merhaba

Aşağıdaki kodda koyu renkle belirtilmiş 3 yazan yerleri 4 yapmanız yeterlidir.

For j = i + 1 To sona

If Cells(j, 1).Interior.Color = RGB(255, 255, 255) And Left(Trim(Cells(i, 1)), 3) = Left(Trim(Cells(j, 1)), 3) Then

Cells(i, 1).Interior.Color = RGB(s1, s2, s3)
Cells(j, 1).Interior.Color = RGB(s1, s2, s3)

Cells(i, 2) = "Grup " & Left(Trim(Cells(i, 1)), 3)
Cells(j, 2) = "Grup " & Left(Trim(Cells(j, 1)), 3)


End If

Next


Selamlar...
 

Ekli dosyalar

Son düzenleme:
Katılım
21 Temmuz 2015
Mesajlar
20
Excel Vers. ve Dili
EXCEL 2013 PROFESIONAL PLUS
Merhaba

Aşağıdaki kodda koyu renkle belirtilmiş 3 yazan yerleri 4 yapmanız yeterlidir.

For j = i + 1 To sona

If Cells(j, 1).Interior.Color = RGB(255, 255, 255) And Left(Trim(Cells(i, 1)), 3) = Left(Trim(Cells(j, 1)), 3) Then

Cells(i, 1).Interior.Color = RGB(s1, s2, s3)
Cells(j, 1).Interior.Color = RGB(s1, s2, s3)

Cells(i, 2) = "Grup " & Left(Trim(Cells(i, 1)), 3)
Cells(j, 2) = "Grup " & Left(Trim(Cells(j, 1)), 3)


End If

Next


Selamlar...
ÇOK TEŞEKKÜR EDERİM :)
 
Katılım
21 Temmuz 2015
Mesajlar
20
Excel Vers. ve Dili
EXCEL 2013 PROFESIONAL PLUS
tekrar bir şey rica edecektim. renkli kartuşumuz bitti. aynı formül farklı renkler yerine bir gri , bir beyaz boyayabilir mi acaba?
böylece siyah beyaz çıktıda daha kolay bulabilelim.
şimdiden teşekkürler
aynı yazıyı başka bir sayfaya kopyalıyorum orda renkte görünmüyor.
o problemi nasıl halledebilirim.
=sayfa1!A1
değer kopyalanıyor ama renk gelmiyor.
kafanızı ağrıttım kusura bakmayın
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,332
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Formülle biçimi aktaramazsınız. Sadece değeri alabilirsiniz.

Bu işlem içinde makro kullanmanız gerekir.
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,332
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
En kolay yöntemi kopyala-biçim yapıştır kodudur.

Aşağıdaki kod Sayfa1 A1:A10 arsındaki hücrelerin biçimini Sayfa2 A1:A10 aralığına kopyalar.

C++:
Option Explicit

Sub Bicim_Yapistir()
    Sheets("Sayfa1").Range("A1:A10").Copy
    Sheets("Sayfa2").Range("A1").PasteSpecial xlFormats
    Application.CutCopyMode = 0
End Sub
 
Katılım
21 Temmuz 2015
Mesajlar
20
Excel Vers. ve Dili
EXCEL 2013 PROFESIONAL PLUS
Merhaba

Aşağıdaki kodda koyu renkle belirtilmiş 3 yazan yerleri 4 yapmanız yeterlidir.

For j = i + 1 To sona

If Cells(j, 1).Interior.Color = RGB(255, 255, 255) And Left(Trim(Cells(i, 1)), 3) = Left(Trim(Cells(j, 1)), 3) Then

Cells(i, 1).Interior.Color = RGB(s1, s2, s3)
Cells(j, 1).Interior.Color = RGB(s1, s2, s3)

Cells(i, 2) = "Grup " & Left(Trim(Cells(i, 1)), 3)
Cells(j, 2) = "Grup " & Left(Trim(Cells(j, 1)), 3)


End If

Next


Selamlar...

tekrar bir şey rica edecektim. renkli kartuşumuz bitti. aynı formül farklı renkler yerine bir gri , bir beyaz boyayabilir mi acaba?
böylece siyah beyaz çıktıda daha kolay bulabilelim.
şimdiden teşekkürler
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,332
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

#8 nolu mesaj ekindeki dosyaya göre hazırlanmıştır.

C++:
Option Explicit

Sub Ilk_Dort_Karaktere_Gore_Renklendir()
    Dim Zaman As Double, S1 As Worksheet, Dizi As Object
    Dim Veri As Variant, Son As Long, X As Long
    Dim Renk As Integer, Say As Long, Y As Integer
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Sayfa1")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    On Error Resume Next
    S1.ShowAllData
    If S1.AutoFilterMode Then S1.Range("A1").AutoFilter
    On Error GoTo 0
    
    S1.Range("A:A").Interior.ColorIndex = -4142
    S1.Range("A1").Insert xlDown
    S1.Range("A1") = "DEĞERLER"
    S1.Range("A2:A" & S1.Rows.Count).Sort S1.Range("A2"), xlAscending
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son = 2 Then Son = 3
    
    Veri = S1.Range("A2:A" & Son).Value
    
    ReDim Liste(1 To Son, 1 To 1000)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Not Dizi.Exists(Left(Veri(X, 1), 4)) Then
            Say = Say + 1
            Dizi.Add Left(Veri(X, 1), 4), Say
            Liste(Say, 1) = CStr(Veri(X, 1))
        Else
            For Y = 1 To 1000
                If Liste(Dizi.Item(Left(Veri(X, 1), 4)), Y) = "" Then
                    Liste(Dizi.Item(Left(Veri(X, 1), 4)), Y) = CStr(Veri(X, 1))
                    Exit For
                End If
            Next
        End If
    Next
    
    Renk = 15
    
    For Each Veri In Dizi.Items
        Say = 0
        ReDim Kriter(1 To 1000)
        For Y = 1 To 1000
            If Liste(Veri, Y) <> Empty Then
                Say = Say + 1
                Kriter(Say) = Liste(Veri, Y)
            Else
                Exit For
            End If
        Next
        S1.Range("A1").AutoFilter 1, Criteria1:=Kriter, Operator:=xlFilterValues
        On Error Resume Next
        S1.Range("A2:A" & Son).SpecialCells(xlCellTypeVisible).Interior.ColorIndex = Renk
        S1.ShowAllData
        On Error GoTo 0
        If Renk = 15 Then
            Renk = -4142
        Else
            Renk = 15
        End If
    Next
    
    S1.Range("A1").Delete xlUp
    
    Set S1 = Nothing
    Set Dizi = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
 
Üst