Aktif olan hücrenin renklenme sorunu

[yavuz829]

Merhaba arkadaşlar bu formda arkadaşların yazmış olduğu kodu ThisWorkbook sayfama ekledim aktif olan hücreler renkleniyor. Ancak sayfaya koruma koyduğum zaman makro çalışmiyor. Bu konuda yardımcı olursanız sevinirim. iyi çalışmalar.

 

[mancubus]

aşağıdaki gibi dener misiniz?

Const iInternational As Integer = Not (0)

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

If Target.Row > 27 Then Exit Sub
If Target.Column > 7 Then Exit Sub

Sheets("Sayfa1").Unprotect Password:="1"

Dim iColor As Integer
On Error Resume Next

iColor = Target.Interior.ColorIndex
If iColor < 0 Then
    iColor = 20
Else
    iColor = iColor + 1
End If

If iColor = Target.Font.ColorIndex Then iColor = iColor + 1

Cells.FormatConditions.Delete
With Cells(Target.Row, Target.Column)
    .FormatConditions.Add Type:=2, Formula1:=iInternational
    .FormatConditions(1).Interior.ColorIndex = iColor
End With
With Range(Target.Offset(1 - Target.Row, 0).Address & ":" & Target.Offset(-1, 0).Address)
    .FormatConditions.Add Type:=2, Formula1:=iInternational
End With

Sheets("Sayfa1").Protect Password:="1"

End Sub

 

[yavuz829]

Çok teşekürler hocam yazmış olduğunuz kod excel kitabı için çok güzel. Tek sayfaya da uygulayabilirmiyiz bu kodu.

 

[mancubus]

rica ederim.

kod'daki

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

satırını

Private Sub WorkSheet_SelectionChange(ByVal Target As Range)

satırı ile değiştirin. yeni kodu çalıştırmak istediğiniz sayfanın kod modülüne kopyalayın. ThisWorkbook'taki kodun silinmesi gerektiğini söylemeye gerek yok herhalde.

 

[mukremin.duru1]

Sayın hocam hücrenin içi beyaz olup da veya istediğimiz renge ayarlayıp hücrenin çerçeve kısmının rengini belirleyeceğimiz renge ayarlayabilirmiyiz? Ilk etapta bana hücrenin içi beyaz çerçeve kısmınında her hangi bir renk olması lazım. şimdiden teşekkür eder, iyi günler dilerim.

 

[mancubus]

şimdi seçili hücrede iken uygulayacaksınız. çerçevenin renginin değişmesi size extra bir şey kazandırmayacak. normalde hücre seçili iken kalın siyah bir çerçeve görecekken, şimdi çerçeve rengine göre değişen farklı bir renk göreceksiniz.

yine de denemek isterseniz. mevcut kodda aşağıdaki değişiklikleri yapın

sil:

iColor = Target.Interior.ColorIndex

yerine

iColor = Target.Borders.ColorIndex

sil:

With Cells(Target.Row, Target.Column)
    .FormatConditions.Add Type:=2, Formula1:=iInternational
    .FormatConditions(1).Interior.ColorIndex = iColor
End With

yerine:

With Cells(Target.Row, Target.Column)
    .FormatConditions.Add Type:=2, Formula1:=iInternational
    .FormatConditions(1).Borders.ColorIndex = iColor
End With

 

[mukremin.duru1]

çok süper. Aradığım bir şeydi. çok memnun oldum. Yardımınız için çok teşekkür ederim.

 

[mancubus]

rica ederim. iyi çalışmalar.

 

[yavuz829]

Hocam bu kodların tek sayfaya değilde bütün sayfalardaki bütün hücreler için geçerli olanı da yazarsanız çok iyi olur. Teşekürler.

 

[mancubus]

aslında 1 no.lu mesajda eklediğiniz dosyadaki gibi olacak.

2 no.lu mesajdaki kodu aşağıdaki satırları sildikten sonra ThisWorkbook kod modülüne kopyalayın.

silinecek.

If Target.Row > 27 Then Exit Sub
If Target.Column > 7 Then Exit Sub

eğer tüm sayfalarda koruma varsa

Sheets("Sayfa1").Unprotect Password:="1"

örneğindeki gibi her sayfanın koruma şifresini kaldıracaksınız.

 

[yavuz829]

Çok teşekürler hocam ellerinize sağlık.

 

[Metin_S]

Sayın mancubus merhaba,

Peki tam tersi olursa kodlarda nasıl bir değişiklik yapmak gerekir acaba. Örneğin; belirli hücreler renkli ve bunların içine bilgi girildikçe hücre renginin beyaz olmasını nasıl sağlarız. Şimdiden teşekkür ederim.

 

[mancubus]

merhaba.

bunun için kod kullanmam.
veri girişi yapılacak aralığı seçerim. örnek A1:E500 olsun.
bu aralığı seçtikten sonra formül ile koşullu biçimlendirme yaparım. formül olarak =EBOŞSA(A1) / =ISBLANK(A1) yazar dolgu rengini seçerim.
bu aralıktaki bir hücreye veri girişi yaptıkça dolgu rengi kalkacaktır.

 

[yavuz829]

Hocam ThisWorkbook sayfasına kodu yapıştiriyorom. Sayfa korumalı Aktif hücrenin bütün sayfalar için geçerli olası için. Aşağıdaki iki kodun yerine hangi kodların yazılması lazım. Birde veri adına bir sayfam var İlk açılışta veri sayıfasının açılmasını istiyorum. Onun için de kod yazarsanız sevinirim. Yardımlarınız için şimdiden teşekürler.


Sheets("Sayfa1").Unprotect Password:="1"

Sheets("Sayfa1").Protect Password:="1"

 

[mancubus]

aşağıdaki gibi deneyin.

şu bölümü kendi ihtiyacınıza göre düzenleyin. tüm sayfada çalışmasını istiyorsanız silin. veya yeni satır ve sütun no tanımlayın.

If Target.Row > 27 Then Exit Sub
If Target.Column > 7 Then Exit Sub

Const iInternational As Integer = Not (0)

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

Application.ScreenUpdating = False

If Target.Row > 27 Then Exit Sub
If Target.Column > 7 Then Exit Sub

Sheets("Sayfa1").Unprotect Password:="1"
Sheets("Sayfa2").Unprotect Password:="2"
Sheets("Sayfa3").Unprotect Password:="3"

Dim iColor As Integer
On Error Resume Next

iColor = Target.Interior.ColorIndex
If iColor < 0 Then
    iColor = 20
Else
    iColor = iColor + 1
End If

If iColor = Target.Font.ColorIndex Then iColor = iColor + 1

Cells.FormatConditions.Delete
With Cells(Target.Row, Target.Column)
    .FormatConditions.Add Type:=2, Formula1:=iInternational
    .FormatConditions(1).Interior.ColorIndex = iColor
End With
With Range(Target.Offset(1 - Target.Row, 0).Address & ":" & Target.Offset(-1, 0).Address)
    .FormatConditions.Add Type:=2, Formula1:=iInternational
End With

Sheets("Sayfa1").Protect Password:="1"
Sheets("Sayfa2").Protect Password:="2"
Sheets("Sayfa3").Protect Password:="3"

Application.ScreenUpdating = True

End Sub

 

[yavuz829]

Çok teşekürler hocam ellerinize sağlık. Hocam ekli dosyamın her açılışında Veri sayfasının açılmasını istiyorum. Sizin yazmış olduğunun kod ile ilk açılan sayıfa kodu çakışıyor. Bir zahmet onu da ayarlayabilirmisiniz. teşekürler.

Dosyanın açılış parolası :321


Private Sub Workbook_BeforeClose(Cancel As Boolean)
ThisWorkbook.Save
Application.Quit
End Sub

Private Sub Workbook_Open()
Sheets("Veri").Select
End Sub
Const iInternational As Integer = Not (0)

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

Application.ScreenUpdating = False

If Target.Row > 100 Then Exit Sub
If Target.Column > 20 Then Exit Sub

Sheets("Veri").Unprotect Password:="12345"
Sheets("Çek-Senet").Unprotect Password:="2"
Sheets("24 Snt").Unprotect Password:="3"

Dim iColor As Integer
On Error Resume Next

iColor = Target.Interior.ColorIndex
If iColor < 0 Then
iColor = 20
Else
iColor = iColor + 1
End If

If iColor = Target.Font.ColorIndex Then iColor = iColor + 1

Cells.FormatConditions.Delete
With Cells(Target.Row, Target.Column)
.FormatConditions.Add Type:=2, Formula1:=iInternational
.FormatConditions(1).Interior.ColorIndex = iColor
End With
With Range(Target.Offset(1 - Target.Row, 0).Address & ":" & Target.Offset(-1, 0).Address)
.FormatConditions.Add Type:=2, Formula1:=iInternational
End With

Sheets("Veri").Protect Password:="1"
Sheets("Çek-Senet").Protect Password:="2"
Sheets("24 Snt").Protect Password:="3"

Application.ScreenUpdating = True

End Sub

 

[mancubus]

aşağıdaki gibi dener misiniz?

Private Sub Workbook_Open()
Sheets("Veri").[B][COLOR="Red"]Activate[/COLOR][/B]
End Sub

 

[yavuz829]

Hocam kodlar bu şekilde aktif hücreler renklenmiyor.

Private Sub Workbook_Open()
Sheets("Sayfa1").Activate
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

Application.ScreenUpdating = False

Sheets("Sayfa1").Unprotect Password:="12345"
Sheets("Sayfa2").Unprotect Password:="12345"
Sheets("Sayfa3").Unprotect Password:="12345"

Dim iColor As Integer
On Error Resume Next

iColor = Target.Interior.ColorIndex
If iColor < 0 Then
iColor = 25
Else
iColor = iColor + 1
End If

If iColor = Target.Font.ColorIndex Then iColor = iColor + 1

Cells.FormatConditions.Delete
With Cells(Target.Row, Target.Column)
.FormatConditions.Add Type:=2, Formula1:=iInternational
.FormatConditions(1).Interior.ColorIndex = iColor
End With
With Range(Target.Offset(1 - Target.Row, 0).Address & ":" & Target.Offset(-1, 0).Address)
.FormatConditions.Add Type:=2, Formula1:=iInternational
End With

Sheets("Sayfa1").Protect Password:="12345"
Sheets("Sayfa2").Protect Password:="12345"
Sheets("Sayfa3").Protect Password:="12345"

Application.ScreenUpdating = True

End Sub

 

[mancubus]

dosyanızdaki kodda yer alan koruma ve koruma kaldırma şifrelerini buradaki gibi düzeltmemişsiniz.

 

[yavuz829]

Hocam çok teşekürler şimdi oldu.