Soru Korumalı Sayfada Makro Kullanmak

By.TRabZonLutm · Cuma saat 10:40'de

Merhaba arkadaşlar, Excel dosyamda arama yapınca bulduğu satır ve hücre renkli yapması için kod kullanıyorum. Bunda sorun yok. Fakat sayfa koruma yapınca makro çalışmıyor. Sayfa koruma şifresi; 123

Makro isminden sonra
ActiveSheet.Unprotect (123)

Son satırından öncede
ActiveSheet.Protect (123)
yazdığımızda makrolar normal çalışıyor. Fakat sayfa koruma yaptığım ayarlar kayboluyor. Filtreleme ve sıralama, satır elle ve satır sil etkin yapıyorum . Kişi sıralama ve filtreleme yapsın. Satır ekleyip silebilsin ama o seçenekleri siliyor.

Kodu nasıl duzenlerim

Kod:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
ActiveSheet.Unprotect (123)

Cells.Interior.ColorIndex = xlColorIndexNone
If IsEmpty(Target) Or Target.Cells.Count > 1 Then Exit Sub
With ActiveCell
    Range(Cells(.Row, .CurrentRegion.Column), Cells(.Row, .CurrentRegion.Columns.Count + .CurrentRegion.Column - 1)).Interior.ColorIndex = 17
    Range(Cells(.CurrentRegion.Row, .Column), Cells(.CurrentRegion.Rows.Count + .CurrentRegion.Row - 1, .Column)).Interior.ColorIndex = 19
    ActiveCell.Cells.Interior.ColorIndex = 4
ActiveSheet.Protect (123)
End With
End Sub

tugkan · Cuma saat 10:51'de

Kodu da yazı olarak ekler misiniz. Yardımcı olmak isteyenlerin işi kolaylaşmış olur.

By.TRabZonLutm · Cuma saat 11:00'de

tugkan' Alıntı:
Kodu da yazı olarak ekler misiniz. Yardımcı olmak isteyenlerin işi kolaylaşmış olur.

Tamamdır ekledim hocam

tugkan · Cuma saat 11:04'de

Dener misiniz?

Makro çalışırken sayfa korumasını kaldırıp tekrar etkinleştirdiğinizde, koruma ile birlikte ek koruma ayarlarını (filtreleme, sıralama, satır ekleme ve silme) yeniden tanımlamanız gerekir. Bunun için, ActiveSheet.Protect satırına ek ayarlar eklemeniz gerekiyor. Aşağıda bu ayarları içerecek şekilde kodunuzu güncelledim:

Kod:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ' Sayfa korumasını kaldır
    ActiveSheet.Unprotect Password:="123"

    ' Hücrelerin önceki renklendirmelerini kaldır
    Cells.Interior.ColorIndex = xlColorIndexNone
    
    ' Birden fazla hücre seçildiyse veya hücre boşsa çık
    If IsEmpty(Target) Or Target.Cells.Count > 1 Then Exit Sub
    
    ' Seçili hücre için renklendirme ayarları
    With ActiveCell
        Range(Cells(.Row, .CurrentRegion.Column), Cells(.Row, .CurrentRegion.Columns.Count + .CurrentRegion.Column - 1)).Interior.ColorIndex = 17
        Range(Cells(.CurrentRegion.Row, .Column), Cells(.CurrentRegion.Rows.Count + .CurrentRegion.Row - 1, .Column)).Interior.ColorIndex = 19
        ActiveCell.Cells.Interior.ColorIndex = 4
    End With

    ' Sayfa korumasını, belirli izinlerle tekrar etkinleştir
    ActiveSheet.Protect Password:="123", AllowFiltering:=True, AllowSorting:=True, AllowDeletingRows:=True, AllowInsertingRows:=True
End Sub

Bu güncelleme ile:

Filtreleme ve sıralama işlemleri: AllowFiltering ve AllowSorting parametreleri ile aktif hale getirilir.
Satır ekleme ve silme izinleri: AllowDeletingRows ve AllowInsertingRows ile tanımlanır.

Böylece sayfa her korunduğunda bu ayarlar korunur ve istediğiniz şekilde çalışır.

By.TRabZonLutm · Cuma saat 14:09'de

tugkan' Alıntı:
Dener misiniz?

Makro çalışırken sayfa korumasını kaldırıp tekrar etkinleştirdiğinizde, koruma ile birlikte ek koruma ayarlarını (filtreleme, sıralama, satır ekleme ve silme) yeniden tanımlamanız gerekir. Bunun için, ActiveSheet.Protect satırına ek ayarlar eklemeniz gerekiyor. Aşağıda bu ayarları içerecek şekilde kodunuzu güncelledim:

Kod:

Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' Sayfa korumasını kaldır ActiveSheet.Unprotect Password:="123" ' Hücrelerin önceki renklendirmelerini kaldır Cells.Interior.ColorIndex = xlColorIndexNone ' Birden fazla hücre seçildiyse veya hücre boşsa çık If IsEmpty(Target) Or Target.Cells.Count > 1 Then Exit Sub ' Seçili hücre için renklendirme ayarları With ActiveCell Range(Cells(.Row, .CurrentRegion.Column), Cells(.Row, .CurrentRegion.Columns.Count + .CurrentRegion.Column - 1)).Interior.ColorIndex = 17 Range(Cells(.CurrentRegion.Row, .Column), Cells(.CurrentRegion.Rows.Count + .CurrentRegion.Row - 1, .Column)).Interior.ColorIndex = 19 ActiveCell.Cells.Interior.ColorIndex = 4 End With ' Sayfa korumasını, belirli izinlerle tekrar etkinleştir ActiveSheet.Protect Password:="123", AllowFiltering:=True, AllowSorting:=True, AllowDeletingRows:=True, AllowInsertingRows:=True End Sub

Bu güncelleme ile:

Filtreleme ve sıralama işlemleri: AllowFiltering ve AllowSorting parametreleri ile aktif hale getirilir.

Satır ekleme ve silme izinleri: AllowDeletingRows ve AllowInsertingRows ile tanımlanır.

Böylece sayfa her korunduğunda bu ayarlar korunur ve istediğiniz şekilde çalışır.

Hocam teşekkür ediyorum ilginiz için, diğer tüm bölümlerin de kodlarını yazar mısınız? Nesne düzenle vs.

Son olarak bazı satir ve hücrelerde renklendirme var. Kod çalışınca tüm sayfadaki dolgu renkleri de gidiyor. Bunu da düzeltmenin bir yolu var mıdır?

pitchoute · Cuma saat 22:14'de

CSS:

Dim previousRange As Range

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Application.EnableEvents = False
    On Error GoTo Cleanup
    ActiveSheet.Unprotect Password:="123"
    If Not previousRange Is Nothing Then
        previousRange.Interior.ColorIndex = xlColorIndexNone
    End If
    If IsEmpty(Target) Or Target.Cells.Count > 1 Then GoTo Cleanup
    With ActiveCell
        Dim rowRange As Range
        Dim colRange As Range
        Set rowRange = Range(Cells(.Row, .CurrentRegion.Column), Cells(.Row, .CurrentRegion.Columns.Count + .CurrentRegion.Column - 1))
        Set colRange = Range(Cells(.CurrentRegion.Row, .Column), Cells(.CurrentRegion.Rows.Count + .CurrentRegion.Row - 1, .Column))
        rowRange.Interior.ColorIndex = 17
        colRange.Interior.ColorIndex = 19
        .Interior.ColorIndex = 4
        Set previousRange = Union(rowRange, colRange)
    End With
Cleanup:
    ActiveSheet.Protect Password:="123", _
        AllowSorting:=True, AllowFiltering:=True, _
        AllowInsertingRows:=True, AllowDeletingRows:=True, _
        Contents:=True, UserInterfaceOnly:=True
    Application.EnableEvents = True
End Sub

İyi akşamlar, deneyip sonucu paylaşabilir misiniz;

By.TRabZonLutm · Cumartesi saat 14:50'de

pitchoute' Alıntı:

CSS:

Dim previousRange As Range

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Application.EnableEvents = False
    On Error GoTo Cleanup
    ActiveSheet.Unprotect Password:="123"
    If Not previousRange Is Nothing Then
        previousRange.Interior.ColorIndex = xlColorIndexNone
    End If
    If IsEmpty(Target) Or Target.Cells.Count > 1 Then GoTo Cleanup
    With ActiveCell
        Dim rowRange As Range
        Dim colRange As Range
        Set rowRange = Range(Cells(.Row, .CurrentRegion.Column), Cells(.Row, .CurrentRegion.Columns.Count + .CurrentRegion.Column - 1))
        Set colRange = Range(Cells(.CurrentRegion.Row, .Column), Cells(.CurrentRegion.Rows.Count + .CurrentRegion.Row - 1, .Column))
        rowRange.Interior.ColorIndex = 17
        colRange.Interior.ColorIndex = 19
        .Interior.ColorIndex = 4
        Set previousRange = Union(rowRange, colRange)
    End With
Cleanup:
    ActiveSheet.Protect Password:="123", _
        AllowSorting:=True, AllowFiltering:=True, _
        AllowInsertingRows:=True, AllowDeletingRows:=True, _
        Contents:=True, UserInterfaceOnly:=True
    Application.EnableEvents = True
End Sub

İyi akşamlar, deneyip sonucu paylaşabilir misiniz;

elinize sağlık hocam fakat makro kullanınca yaptığım dolgular da gidiyor maalesef. sayfadaki tüm dolguları siliyor.

pitchoute · Cumartesi saat 17:26'de

Tekrardan merhaba,

Kod modülünüzün üstüne aşağıdaki kodu ekleyin:

Kod:

Dim previousRange As Range
Dim cellColors As Object

SelectionChange olayını düzenleyin:

Kod:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Application.EnableEvents = False
    On Error GoTo Cleanup
    ActiveSheet.Unprotect Password:="123"
    If Not previousRange Is Nothing Then
        Dim cell As Range
        For Each cell In previousRange
            If cellColors.Exists(cell.Address) Then
                cell.Interior.Color = cellColors(cell.Address)
            Else
                cell.Interior.ColorIndex = xlColorIndexNone
            End If
        Next cell
    End If
    Set cellColors = CreateObject("Scripting.Dictionary")
    If IsEmpty(Target) Or Target.Cells.Count > 1 Then GoTo Cleanup
    With ActiveCell
        Dim rowRange As Range
        Dim colRange As Range
        Set rowRange = Range(Cells(.Row, .CurrentRegion.Column), Cells(.Row, .CurrentRegion.Columns.Count + .CurrentRegion.Column - 1))
        Set colRange = Range(Cells(.CurrentRegion.Row, .Column), Cells(.CurrentRegion.Rows.Count + .CurrentRegion.Row - 1, .Column))
        For Each cell In Union(rowRange, colRange)
            cellColors.Add cell.Address, cell.Interior.Color
        Next cell
        rowRange.Interior.ColorIndex = 17
        colRange.Interior.ColorIndex = 19
        .Interior.ColorIndex = 4
        Set previousRange = Union(rowRange, colRange)
    End With

Cleanup:
    ActiveSheet.Protect Password:="123", _
        AllowSorting:=True, AllowFiltering:=True, _
        AllowInsertingRows:=True, AllowDeletingRows:=True, _
        Contents:=True, UserInterfaceOnly:=True
    Application.EnableEvents = True
End Sub

By.TRabZonLutm · Cumartesi saat 18:27'de

pitchoute' Alıntı:

Tekrardan merhaba,

Kod modülünüzün üstüne aşağıdaki kodu ekleyin:

Kod:

Dim previousRange As Range
Dim cellColors As Object

SelectionChange olayını düzenleyin:

Kod:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Application.EnableEvents = False
    On Error GoTo Cleanup
    ActiveSheet.Unprotect Password:="123"
    If Not previousRange Is Nothing Then
        Dim cell As Range
        For Each cell In previousRange
            If cellColors.Exists(cell.Address) Then
                cell.Interior.Color = cellColors(cell.Address)
            Else
                cell.Interior.ColorIndex = xlColorIndexNone
            End If
        Next cell
    End If
    Set cellColors = CreateObject("Scripting.Dictionary")
    If IsEmpty(Target) Or Target.Cells.Count > 1 Then GoTo Cleanup
    With ActiveCell
        Dim rowRange As Range
        Dim colRange As Range
        Set rowRange = Range(Cells(.Row, .CurrentRegion.Column), Cells(.Row, .CurrentRegion.Columns.Count + .CurrentRegion.Column - 1))
        Set colRange = Range(Cells(.CurrentRegion.Row, .Column), Cells(.CurrentRegion.Rows.Count + .CurrentRegion.Row - 1, .Column))
        For Each cell In Union(rowRange, colRange)
            cellColors.Add cell.Address, cell.Interior.Color
        Next cell
        rowRange.Interior.ColorIndex = 17
        colRange.Interior.ColorIndex = 19
        .Interior.ColorIndex = 4
        Set previousRange = Union(rowRange, colRange)
    End With

Cleanup:
    ActiveSheet.Protect Password:="123", _
        AllowSorting:=True, AllowFiltering:=True, _
        AllowInsertingRows:=True, AllowDeletingRows:=True, _
        Contents:=True, UserInterfaceOnly:=True
    Application.EnableEvents = True
End Sub

bu şekilde yapıştırdım hocam fakat, ctrl+f ile arama yapınca bulduğu hücre ve satırı vs. renklendirmiyor.