sayıya göre renge boyama

T

tubitakexcel

Katılım
21 Temmuz 2015
Mesajlar
20
Excel Vers. ve Dili
EXCEL 2013 PROFESIONAL PLUS
Altın Üyelik Bitiş Tarihi
06-11-2023
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

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

aligunes

Altın Üye
Katılım
2 Mart 2005
Mesajlar
304
Excel Vers. ve Dili
Ofis 2016 TR 32 Bit
Altın Üyelik Bitiş Tarihi
09-06-2025
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
 
T

tubitakexcel

Katılım
21 Temmuz 2015
Mesajlar
20
Excel Vers. ve Dili
EXCEL 2013 PROFESIONAL PLUS
Altın Üyelik Bitiş Tarihi
06-11-2023
yaptım ama olmuyor. birde siz bakar mısınız?
aşama aşama hepsini seçtim olmuyor :(
 

Ekli dosyalar

Orion1

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

kulomer46

Altın Üye
Katılım
23 Mart 2007
Mesajlar
1,513
Excel Vers. ve Dili
Microsoft Office LTSC Professional Plus 2021 - Türkçe
Altın Üyelik Bitiş Tarihi
08-06-2027
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:
T

tubitakexcel

Katılım
21 Temmuz 2015
Mesajlar
20
Excel Vers. ve Dili
EXCEL 2013 PROFESIONAL PLUS
Altın Üyelik Bitiş Tarihi
06-11-2023
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 :)
 
T

tubitakexcel

Katılım
21 Temmuz 2015
Mesajlar
20
Excel Vers. ve Dili
EXCEL 2013 PROFESIONAL PLUS
Altın Üyelik Bitiş Tarihi
06-11-2023
kulomer46' Alıntı:
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
 
T

tubitakexcel

Katılım
21 Temmuz 2015
Mesajlar
20
Excel Vers. ve Dili
EXCEL 2013 PROFESIONAL PLUS
Altın Üyelik Bitiş Tarihi
06-11-2023
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
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,456
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

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,456
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
 
T

tubitakexcel

Katılım
21 Temmuz 2015
Mesajlar
20
Excel Vers. ve Dili
EXCEL 2013 PROFESIONAL PLUS
Altın Üyelik Bitiş Tarihi
06-11-2023
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
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,456
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
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst