Sütunda bulunan sayı kadar sağ tarafa boyama

[S.Yiğit]

Merhaba,

E sütununda bulunan sayı kadar sağ tarafa boyama yapmam lazım. Örneği incelerseniz ne yapmak istediğimi anlarsınız. Ben olması gereken boyama işlemini manuel yaptım.

2003 formatında örneğim ektedir.

 

[zafer]

Merhaba

Ekli dosyayı inceleyiniz.

 

[zafer]

Merhaba

Makro çalıştığında hücrelerdeki zemin rengini dolgusuz yapmak için
Kodların başına alttaki kodu kopyalayınız.

Range("f2:IV5000").Interior.ColorIndex = xlNone
    Range("f2").Select

 

[Necdet]

Merhaba,

Bende birşeyler yapmıştım, altarnetaf olsun.

Kodları bir modüle kopyalayıp deneyiniz.

Sub Renklendir()
 
    Dim i       As Integer
    Dim j       As Integer
    Dim BasKol  As Integer
    Dim BitKol  As Integer
    
    Application.ScreenUpdating = False
    
    BasKol = 6
    j = Cells(Rows.Count, "E").End(3).Row
    Range("F2:IV" & j).Interior.ColorIndex = xlNone
    
    For i = 2 To j
        BitKol = BasKol + Cells(i, "E") - 1
        Range(Cells(i, BasKol), Cells(i, BitKol)).Interior.ColorIndex = 3
        BasKol = BitKol + 1
    Next i
    
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamamdır...", vbInformation, "N. YEŞERTENER ----> [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
    
End Sub

 

[S.Yiğit]

Zafer bey, Necdet bey, Merhaba,
Kodlar için teşekkür ederim. Her iki kodda güzel çalışıyor. Mümkünse kod E hücresindeki değer değiştiğinde tetiklenebilir mi? Sayıları sırayla veya karışık girip entere basıyoruz bu esnada kod çalışırsa benim için daha iyi olacak. Tekrar teşekkürler.

 

[Necdet]

Merhaba,

İlgili sayfanın kod bölümüne kopyalayanız aşağıdaki kodları.

Private Sub Worksheet_Change(ByVal Target As Range)
 
    If Intersect(Target, [E:E]) Is Nothing Then Exit Sub
    If Target.Row < 2 Then Exit Sub
    
    Dim i       As Integer
    Dim j       As Integer
    Dim BasKol  As Integer
    Dim BitKol  As Integer
    
    Application.ScreenUpdating = False
    
    BasKol = 6
    j = Cells(Rows.Count, "E").End(3).Row
    Range("F2:IV" & j).Interior.ColorIndex = xlNone
    
    For i = 2 To j
        BitKol = BasKol + Cells(i, "E") - 1
        Range(Cells(i, BasKol), Cells(i, BitKol)).Interior.ColorIndex = 3
        BasKol = BitKol + 1
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

 

[S.Yiğit]

Necdet bey, çok teşekkür ederim.