• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

sayıya göre renge boyama

T

tubitakexcel

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
 
Koşullu biçimlendirme işinize yarayacaktır.:cool:
 
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
 
yaptım ama olmuyor. birde siz bakar mısınız?
aşama aşama hepsini seçtim olmuyor :(
 

Ekli dosyalar

Kodda 3 yazan yeri 4 yapınız.:cool:
 
tubitakexcel' Alıntı:
çok teşekkür ederim. sizden bir ricam daha olacaktı. 3 değilde 4 rakama göre ayarlama yapabilir misiniz?
Genişletmek için tıkla ...

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:
kulomer46' Alıntı:
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...
Genişletmek için tıkla ...
ÇOK TEŞEKKÜR EDERİM :)
 
tubitakexcel' Alıntı:
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
Genişletmek için tıkla ...
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
 
Formülle biçimi aktaramazsınız. Sadece değeri alabilirsiniz.

Bu işlem içinde makro kullanmanız gerekir.
 
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
 
kulomer46' Alıntı:
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...
Genişletmek için tıkla ...


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
 
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
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst