AccessTr.neT

(29/04/2020, 10:14)lion2577 yazdı: [ -> ]

(28/04/2020, 14:25)lion2577 yazdı: [ -> ]İlginiz için çok teşekkür ederim. Yapmak istediğim işlemi şöyle açıklayayım. Yukarıdaki kod bulunduğun hücreyi yatay ve dikey olarak renklendiriyor. Ben bu kodu  herhangi bir düğmeye veya butonu atamak istiyorum. Amacım bu düğmeye istediğimiz zaman bastığımızda bulunduğumuz hücreyi yatay ve düşey olarak renklendirsin. İstediğimiz zamanda tekrar düğmeye bastığımız da reklendirmeyi durdursun. Bu düğmeyi de menüye ekleyerek her Excel dosyasında kullanmak istiyorum.

(28/04/2020, 21:37)feraz yazdı: [ -> ]Doğru anladıysam birşeler yaptım.




Modül kodlar;

Public dursunmu As Boolean



Public Sub Basla()

    dursunmu = False

End Sub



Public Sub Durdur()

      dursunmu = True

End Sub

Sayfa kodlar;

Sub Worksheet_SelectionChange(ByVal Target As Range)

    Static xRow

    Static xColumn

    

    If dursunmu = True Then

        Cells.Interior.ColorIndex = xlNone

        Exit Sub

    End If

    

    If xColumn <> "" Then

        Columns(xColumn).Interior.ColorIndex = xlNone

        Rows(xRow).Interior.ColorIndex = xlNone

    End If

    

    pRow = Selection.Row

    pColumn = Selection.Column

    xRow = pRow

    xColumn = pColumn

    With Columns(pColumn).Interior

        .ColorIndex = 6

        .Pattern = xlSolid

    End With

    With Rows(pRow).Interior

        .ColorIndex = 6

        .Pattern = xlSolid

    End With

End Sub

---

Eğer verdiğim ilgili kodu alttaki gibi yaparsanız makro çalışınca renkler gider.

Public Sub Durdur()

      dursunmu = True

      Cells.Interior.ColorIndex = xlNone

End Sub

İlgi alaka ve emeğiniz için teşekkür ederiz. Yapmış olduğunuz çalışmada eğer hücreler renkliyse veya renklendirilecekse onlarıda siliyor.

Rica ederim kodlar zaten sizin üstad.
Cells.intetior.colorindex= xlnone
Bu koduda eklediyseniz rayfanın genelindeki renkleri siler.Belirli alan için yapacaksanız 
Range("A1:E100") ile değiştirin örneğin cells yazan yeri.

Yada kışullu bişimlendirme ilede oluyor bidiğim lakin ordada heralde seçilen satır ve sütundaki koşullu biçimlendirme renkleri siliniyor yinede emin değilim.

Koşullu biçimlendirme kodlarını yazayım iserseniz.
A1:M100 aralığındaki sadece koşullu biçimlendirme renkler silinir ani başka varsa bu aralıkta.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)



If Not Intersect(Target, Range("A1:M100")) Is Nothing Then



  [A1:M100].FormatConditions.Delete



    Set satir = Range("A" & Target.Row, "M" & Target.Row)

    Set sütun = Range(Cells(1, Target.Column), Cells(100, Target.Column))

    Set feraz = Union(satir, sütun)

    

  

    feraz.FormatConditions.Add Type:=xlExpression, Formula1:="1"

    feraz.FormatConditions(1).Interior.ColorIndex = 4 'yesil renk



Else

    [A1:M100].FormatConditions(1).Interior.ColorIndex = 0

End If



End Sub

Arşivimden bir dosya buldum galiba bunda renkler bozulmuyor.
Kosullu diye sayfa olmalı yoksa çalışmaz.
Kullanırsanız diğer kodları uyarlayabilirsiniz.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)



Dim ws As Worksheet, aa As Integer, bb As Integer, cc As Integer



Set ws = ThisWorkbook.Sheets("Kosullu")

On Error GoTo son

If Target.Count > 1 Then GoTo son



Application.ScreenUpdating = False

  ws.Cells.ClearContents



    bb = 50

    

        If Target.Column < 50 Then

            cc = 1 - Target.Column

        Else

            cc = -50

        End If

    

        If Target.Row < 50 Then

            aa = 1 - Target.Row

        Else

            aa = -50

        End If

    

    ws.Range(Target.Address, ws.Range(Target.Address).Offset(0, cc)).Value = 1

    ws.Range(Target.Address, ws.Range(Target.Address).Offset(0, 50)).Value = 1

    ws.Range(Target.Address, ws.Range(Target.Address).Offset(aa, 0)).Value = 1

    ws.Range(Target.Address, ws.Range(Target.Address).Offset(50, 0)).Value = 1

    

  

Application.ScreenUpdating = True

Exit Sub

son:

ws.Cells.ClearContents

Set ws = Nothing

End Sub

Yapmış olduğunuz bu çalışmayı düğmeye atayarak başlattıp durdurabilirmiyiz. Tekrar çok teşekkür ederim.

Sadece 5.mesajdaki kodu uygulayacaksınız.

Alttaki sayfa kodunu ekleyeceksiniz verdiğim koda.
If dursunmu = True Then

Dosyayı hazırladım